./  ADD    NAME=APLDEV
         MACRO                                                          00630000
&L       APLDEV &ADR,&TYPE=AMBIG,&SAD=SAD1,&EXPRESS=NO                  01260000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01890000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02520000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03150000
         GBLA  &PADR,&TCNT,&FADR                                        03780000
         GBLB  &TERMT                                                   04410000
         GBLC  &TERMTL,&PUBFIR,&PUBLAST                                 05040000
         LCLA  &ADR2,&ADR3,&ADR4,&ADR5                                  05670000
         LCLB  &LB1,&LB2,&LB3,&LB4                                      06300000
         LCLC  &LC1,&LC2,&LC3                                           06930000
.*       &LB1  TRUE FOR 270X DEVICE                                     07560000
.*       &LB2  TRUE FOR AUXILIARY                                       08190000
.*       &LB3  TRUE FOR HARD-WIRED 270X DEVICE                          08820000
.*       &LB4  TRUE FOR AN EXPRESS PORT                                 09450000
         LCLA  &ADR2HI                                                  10080000
         AIF   (N'&ADR EQ 1  OR  N'&ADR EQ 2).ADROK                     10710000
.ADRNG   MNOTE 16,'INVALID FORMAT FOR DEVICE ADDRESS PARAMETER '  &ADR  11340000
         MNOTE 16,'MACRO IGNORED.'                                      11970000
         MEXIT                     BETTER LUCK NEXT TIME                12600000
.ADROK   ANOP                                                           13230000
         AIF   (T'&ADR(1) EQ 'O'  OR  T'&ADR(N'&ADR) EQ 'O').ADRNG      13860000
.*                                                                      14490000
.*  THE POSITIONAL PARAMETER &ADR CAN HAVE TWO FORMS:                   15120000
.*       1)    X'##' OR ##         TO INDICATE A SINGLE PORT            15750000
.*       2)    (FIRST,LAST)        TO GENERATE ALL PORTS WITH ADDRESSES 16380000
.*                                   FROM FIRST TO LAST INCLUSIVE,      17010000
.*                                   HAVING IDENTICAL CHARACTERISTICS.  17640000
.*                                                                      18270000
&ADR2    SETA  &ADR(1)           FIRST OF A GROUP OF CONSECUTIVE PORTS  18900000
&ADR2HI  SETA  &ADR(N'&ADR)       LAST OF A GROUP OF CONSECUTIVE PORTS  19530000
         AIF   (&ADR2 GT &ADR2HI).ADRNG WE DONT WANT TO COUNT BACKWARD  20160000
&LB4     SETB  ('&EXPRESS' EQ 'YES')                                    20790000
&LB3     SETB  ('&TYPE' EQ '1050' OR '&TYPE' EQ '2741' OR              X21420000
               '&TYPE' EQ 'TS41')                                       22050000
&LB2     SETB  ('&TYPE' EQ 'AUX')                                       22680000
&LB1     SETB  (&LB3 OR '&TYPE' EQ 'AMBIG')                             23310000
         AIF   (&LB1 OR &LB2 OR '&TYPE' EQ '1052' OR                   X23940000
               '&TYPE' EQ 'END').OKTYP                                  24570000
         MNOTE 16,'INVALID DEVICE TYPE, MACRO IGNORED'                  25200000
         MEXIT                                                          25830000
.OKTYP   ANOP                                                           26460000
         AIF   ('&SAD' EQ 'SAD0').OKSAD                                 27090000
         AIF   ('&SAD' EQ 'SAD1').OKSAD                                 27720000
         AIF   ('&SAD' EQ 'SAD2').OKSAD                                 28350000
         AIF   ('&SAD' EQ 'SAD3').OKSAD                                 28980000
         AIF   ('&SAD' EQ 'NOP').OKSAD                                  29610000
         MNOTE 16,'INVALID SAD, MACRO IGNORED'                          30240000
         MEXIT                                                          30870000
.OKSAD   ANOP                                                           31500000
         AIF   ('&EXPRESS' EQ 'YES' OR '&EXPRESS' EQ 'NO').OKEXP        32130000
         MNOTE 16,'INVALID EXPRESS DESIGNATION, MACRO IGNORED'          32760000
         MEXIT                                                          33390000
.OKEXP   ANOP                                                           34020000
         AIF   ('&TYPE' EQ 'AUX').A23                                   34650000
         AIF   (&PADR GE &ADR2).A24    SEQUENCE ERROR                   35280000
         AIF   (&PADR+1 NE &ADR2).A2                                    35910000
.A6      AIF   (&ADR2 NE 16*(&ADR2/16)).A1                              36540000
.A2      ANOP                                                           37170000
&ADR3    SETA  &PADR/16                                                 37800000
&ADR4    SETA  &ADR2/16                                                 38430000
         AIF   (&ADR3 NE &ADR4).A3                                      39060000
.*       GENERATE DUMMY PUBENT OR PERTERM                               39690000
&ADR3    SETA  &ADR2-&PADR-1                                            40320000
.A20     ANOP                                                           40950000
&LC3     SETC  'ATERM&TCNT'(1,8*&TERMT)                                 41580000
&LC3     DC    A(0,0,0,0,X'4000')  SAME LENGTH AS PUBENT                42210000
         DC    (&TERMTL-PUBENTL)X'00'                                   42840000
&ADR3    SETA  &ADR3-1                                                  43470000
&TCNT    SETA  &TCNT+1*&TERMT                                           44100000
         AIF   (&ADR3 GT 0).A20                                         44730000
         AGO   .A1                                                      45360000
.A3      AIF   (&PADR LT 0).A4                                          45990000
CONFIG   CSECT                                                          46620000
         ORG   MPXCUTAB+&ADR3*8                                         47250000
&ADR5    SETA  &FADR*256+&PADR                                          47880000
         DC    A(&TERMTL*F*F+&ADR5)                                     48510000
         DC    AL1(0)        PUBN MAY BE NEGATIVE.  AL3 FORCES PROPER   49140000
         DC    AL3(PUB&ADR3)       ADDRESS AFTER LINKEDIT RELOCATION    49770000
.A4      AIF   ('&TYPE' EQ 'END').A12                                   50400000
&FADR    SETA  &ADR2                                                    51030000
&ADR3    SETA  &ADR2-&ADR4*16                                           51660000
&TERMT   SETB  (&LB1)                                                   52290000
&LC3     SETC  'PUBENTPERTERM'(6*&TERMT+1,6+&TERMT)                     52920000
&TERMTL  SETC  '&LC3.L'                                                 53550000
&LC3.G   CSECT                                                          54180000
         ORG                                                            54810000
PUB&ADR4 EQU   *-&TERMTL*&ADR3                                          55440000
.A1      AIF   (&TERMT NE &LB1).A5                                      56070000
&PADR    SETA  &ADR2                                                    56700000
         AIF   (&TCNT EQ 0).A24                                         57330000
.*       THIS CALL REPRESENTS A PHYSICAL DEVICE OF SOME SORT            57960000
         AIF   ('&TYPE' EQ '1052').A10                                  58590000
.*       GENERATE DATA ITEMS FOR PERTERM AREA                           59220000
.A9      ANOP                                                           59850000
ATERM&TCNT APLPUB &ADR2,&TYPE,WRITES                                    60480000
         DC    A(ATERM&TCNT+X'58') PUCCB                                61110000
         AIF   (&FADR NE &ADR2).A31                                     61740000
.A11     ENTRY ATERM&TCNT                                               62370000
.A31     DC    AL1(X'30',X'01',X'40'+X'01'*&LB2,X'80'*&LB3+X'08'*&LB4)  63000000
         DC    A(EMPT3)            PTCORE                               63630000
         BCR   0,0                 MESSCELL                             64260000
         DC    AL2(0) (YYREC)                                           64890000
         DC    2H'0'               RESERVED,PTBUFA                      65520000
         DC    4A(EMPT3)           PTFBUF,PTLBUF,PTIBUF,PTRBUF          66150000
         DC    6F'0' PTABTM,PTICTME,PTMTIME,PTSOTM,PTMTIM2,PTMTIM3      66780000
         DC    2H'0'               PTCPULIM,PTCPULM2                    67410000
         DC    AL1(EMPTYM,&SAD,0,0,0) DESBYTE,PTSAD,PTDNT,PDSOP,PTRESP  68040000
         DC    7X'00'              RESERVED                             68670000
.*       READ AND WRITE CCW CHAIN                                       69300000
         AIF   (&LB3).R3                                                69930000
         CCW   X'2F',0,CC+SLI,1    DISABLE CCW FOR AMBIG TYPE           70560000
         CCW   &SAD,ATERM&TCNT+X'50',SLI,1  SAD CCW                     71190000
         AGO   .R4                                                      71820000
.*       SAD FOLLOWED BY ENABLE FOR NON DIALUP DEVICES.                 72450000
.R3      CCW   &SAD,0,CC+SLI,1     PTCCW1 - SAD.                        73080000
         CCW   X'27',ATERM&TCNT+X'50',SLI,1 PTCCW2 ENABLE               73710000
.R4      DC    A(EMPT3)            PTCCW3 BECOMES TIC                   74340000
         DC    F'0'                PTMAN                                74970000
         DC    4X'00'              PTMANI,LAST BYTE RESERVED            75600000
         DC    2H'0'               PTWSQ,PTWSA                          76230000
&TCNT    SETA  &TCNT+1                                                  76860000
         AIF   (&TERMT OR &LB2).A7                                      77490000
PUBENTG  CSECT                                                          78120000
.A7      ANOP                                                           78750000
&ADR2    SETA  &ADR2+1             INCREMENT PORT NUMBER                79380000
         AIF   (&ADR2 LE &ADR2HI).A6 DO ANOTHER OF CONSECUTIVE PORTS?   80010000
         MEXIT                                                          80640000
.A12     ANOP                                                           81270000
         ORG                                                            81900000
TERMCOUN EQU   &TCNT                                                    82530000
         MEXIT                                                          83160000
.*                                                                      83790000
.*       1052-7 TERMINAL                                                84420000
.*                                                                      85050000
.A10     DC    A(ATERM&TCNT,0,0,0,0)  SAME LENGTH AS PUBENT             85680000
PERTERMG CSECT                                                          86310000
ATERM&TCNT APLPUB &ADR2,1052,READS                                      86940000
         DC    A(ATERM&TCNT+X'68')   PUCCB                              87570000
         AGO   .A11                                                     88200000
.A23     AIF   (&TCNT NE 0).A24                                         88830000
*                                                                       89460000
*        AUXILIARY MESSAGE BUFFER FOR OPERATOR                          90090000
*        COPY SOURCE TERMINAL                                           90720000
*                                                                       91350000
PERTERMG CSECT                                                          91980000
         ENTRY AUXTERM                                                  92610000
AUXTERM  APLPUB X'FF',AUX,IDLE                                          93240000
ATERM&TCNT EQU AUXTERM                                                  93870000
         DC    A(9)                PUCCB  (ILLEGAL CAW SETTING)         94500000
         AGO   .A11                                                     95130000
*                                                                       95760000
.A5      MNOTE 4,'INTERMIXED PUB AND PERTERM BLOCKS'                    96390000
.*       THIS RESTRICTION MIGHT BE REMOVABLE                            97020000
.A24     MNOTE 16,'APLDEV CALLS OUT OF ORDER, MACRO IGNORED'            97650000
         MEXIT                                                          98280000
         MEND                                                           98910000
./  ADD    NAME=APLDS
         MACRO                                                          00890000
&L       APLDS &X,&DS,&RPS=NO,&DC=YES                              5989 01780000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            02670000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  03560000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       04450000
         GBLA  &I                                                       05340000
         GBLA  &E                                                       06230000
         GBLB  &OS                                                      07120000
         GBLC  &CS                                                      08010000
         GBLC  &AA                                                      08900000
         GBLC  &DPARS                                                   09790000
         LCLC  &D(6)                                               2541 10680000
         LCLA  &D1,&D2,&LG                                         2541 11570000
         LCLB  &RP                                                 DASD 12460000
         LCLB  &ISSWAP,&DCH                                        5989 13350000
         LCLC  &A                                                       14240000
         LCLC  &DD                                                      15130000
&ISSWAP  SETB  ('&L' EQ 'SWAP')                                    5989 16020000
&DCH     SETB  ('&DC' EQ 'NO')                                     5989 16910000
         AIF   (&DCH OR '&DC' EQ 'YES').DCOK                       5989 17800000
         MNOTE 0,'DC OPERAND INVALID, YES ASSUMED'                 5989 18690000
.DCOK    AIF   (&OS).OS                                            5989 19580000
         AIF   ('&SYSECT' EQ 'SOFTPARS').A                              20470000
SOFTPARS CSECT                                                          21360000
.A       AIF   (T'&L EQ 'O' AND T'&X NE 'O').B                          22250000
         AIF   ('&DPARS' EQ '&L').B                                     23140000
         AIF   ('&DPARS' EQ '').C                                       24030000
         ENTRY &DPARS.PZ                                                24920000
&DPARS.PZ EQU *-1                                                       25810000
.C       AIF   (T'&X EQ 'O').Z                                          26700000
         ENTRY &L.PARS                                                  27590000
&L.PARS  EQU   *                                                        28480000
&DPARS   SETC  '&L'                                                     29370000
.B       AIF   (T'&DS EQ 'O').T0                                        30260000
         AIF   ('&DS'(1,1) EQ '''' AND '&DS'(K'&DS,1) EQ '''').T1       31150000
.T0      MNOTE 16,'FILE NAME INVALID, MACRO REJECTED'                   32040000
         MEXIT                                                          32930000
.T1      AIF   (&X LT 0 OR &X GT 244).T2                                33820000
         AIF   ('&DPARS' NE 'SWAP' OR (&X NE 4 AND &X NE 5)).T3         34710000
.T2      MNOTE 16,'LOGICAL UNIT INVALID, MACRO REJECTED'                35600000
         MEXIT                                                          36490000
.T3      AIF   (K'&DS LE 44).T4                                         37380000
         MNOTE 0,'FILE NAME TOO LONG, TRUNCATED'                        38270000
.T4      DC    AL1(0,0,1,&X)                                            39160000
         DC    5F'0'                                               5989 40050000
         DC    AL1(B'&RP&ISSWAP&DCH.00000',0,0,0)                  5989 40940000
         DC    F'0'                                                5989 41830000
         DC    CL44&DS                                                  42720000
&I       SETA  &I+1                                                     43610000
.Z       MEXIT                                                          44500000
.OS      ANOP                                                           45390000
.* LOGAD WILL CONTAIN THE NUMBER I CORRESPONDING TO THE ITH DCB.        46280000
.AY      AIF   (&I NE 1).AX                                             47170000
&E       SETA    0                                                      48060000
.AX      AIF   (T'&L EQ 'O').A3                                         48950000
&CS      SETC  '&L'                                                     49840000
&AA      SETC  '&CS.PARS'                                               50730000
.A3      AIF   (T'&X NE 'O').A4                                         51620000
         AIF   (T'&L EQ 'O').A5                                         52510000
&CS      SETC  '&L'                                                     53400000
.A5      ANOP                                                           54290000
&CS.PARS CSECT                                                          55180000
&CS.PZ   EQU   *-1                                                      56070000
         ENTRY &CS.PZ                                                   56960000
         MEXIT                                                          57850000
.A4      ANOP                                                           58740000
&AA      CSECT                                                          59630000
&D2      SETA  2                                                   2541 60520000
&LG      SETA  K'&X-1                                              2541 61410000
         AIF   ('&X'(1,1) EQ '''' AND '&X'(K'&X,1) EQ '''').A1     2541 62300000
&D2      SETA  1                                                   2541 63190000
&LG      SETA  K'&X                                                2541 64080000
.A1      ANOP                                                           64970000
&D1      SETA  &D1+1                                               2541 65860000
         AIF   (&LG-&D2 LT 8).OUT                                  2541 66750000
&D(&D1)  SETC  '&X'(&D2,8)                                         2541 67640000
&D2      SETA  &D2+8                                               2541 68530000
         AGO   .A1                                                 2541 69420000
.OUT     ANOP                                                      2541 70310000
&D(&D1)  SETC  '&X'(&D2,&LG-&D2+1)                                 2541 71200000
&A       SETC  'FILE&I'                                                 72090000
&A       DC    Y(0,&I)                                                  72980000
         DC    5F'0'                                               5989 73870000
         AIF   (T'&DS EQ 'O').DSOK                                 DASD 74760000
         MNOTE 0,'&DS MEANINGLESS, IGNORED'                        DASD 75650000
.DSOK    ANOP                                                      DASD 76540000
&RP      SETB  ('&RPS' EQ 'YES')                                   DASD 77430000
         AIF   (&RP OR '&RPS' EQ 'NO').DC                          DASD 78320000
.*                                                          DASD    **D 79210000
         MNOTE 0,'RPS OPERAND INVALID, NO ASSUMED'                 DASD 80100000
.DC      DC    AL1(B'&RP&ISSWAP&DCH.00000',0,0,0)                  DASD 80990000
         DC    F'0'                                                5989 81880000
         DC    CL44'&D(1).&D(2).&D(3).&D(4).&D(5).&D(6).'          2541 82770000
APLSDCBS CSECT                                                          83660000
         ORG   *+4                                                      84550000
         ENTRY APLDCB&I                                                 85440000
&DD      SETC  'APL&CS&E.'                                              86330000
         AIF   ('&CS' NE 'LIB').DCB                                     87220000
         AIF   (&E GT 9).DCB                                            88110000
&DD      SETC  'APL&CS.0&E.'                                            89000000
.DCB     ANOP                                                           89890000
APLDCB&I DCB   DSORG=DA,DDNAME=&DD,MACRF=(E),                          X90780000
               PCIA=WA,CENDA=WB,XENDA=WC                                91670000
         ORG   APLDCB&I+50                                              92560000
         DC    X'D0'               TURN OFF X'20'                       93450000
         ORG                                                            94340000
         MNOTE *,'//&DD DD DISP=SHR,DSNAME=&D(1).&D(2).&D(3).&D(4).&D(5X95230000
               ).&D(6).'                                           2541 96120000
&I       SETA  &I+1                                                     97010000
&E       SETA   &E+1                                                    97900000
         MEND                                                           98790000
./  ADD    NAME=APLPUB
         MACRO                                                          10000000
&L       APLPUB &ADR,&TYPE,&STATE                                       20000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  30000000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  40000000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       50000000
         DS    0F                                                       60000000
&L       DC    AL1(Q&TYPE,&STATE,&ADR,0)  PTTYPE,STATE,PTUNAD,PUSENS    70000000
         DC    2F'0'               SAVCSW                               80000000
         MEND                                                           90000000
./  ADD    NAME=APLSCONF
       MACRO                                                            00520000
     APLSCONF  &DIRS=5,            NUMBER OF USER DIRECTORIES          *01040000
               &INCORE=3,          NUMBER OF WS SLOTS IN CORE          *01560000
               &WSSIZE=36000,      WORKSPACE SIZE IN BYTES             *02080000
               &HOST=,             HOST APL SYSTEM                     *02600000
               &EXPLIM=8,          EXPRESS TIME LIMIT                  *03120000
               &DOSEND=X'3000',    SEND MACRO PARAMETER FROM DOS SYSGEN*03640000
               &MPXCHAN=0,         MULTIPLEX CHANNEL ADDRESS       5991*04160000
               &IODEBUG=200        SIZE OF I/O DEBUG TRACE TABLE        04680000
.*             5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972               05200000
.*             5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972               05720000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       06240000
         GBLA  &MDEV,&PADR,&CACNT,&WSLN,&TCNT,&MANHASH                  06760000
         GBLA  &MPXCH                                              5991 07280000
         GBLB  &DOS,&OS,&CP67                                           07800000
         GBLC  &PN                                                      08320000
         LCLC  &S                                                       08840000
&MPXCH   SETA  &MPXCHAN                                            5991 09360000
         AIF   ((&MPXCH GE 0) AND (&MPXCH LT 32) AND                   *09880000
               (N'&MPXCHAN EQ 1)).CK00                             5991 10400000
         MNOTE 0,'MPXCHAN OPERAND INVALID, 0 ASSUMED'              5991 10920000
.*                                                          5991    **D 11440000
&MPXCH   SETA  0                                                   5991 11960000
.CK00    ANOP                                                      5991 12480000
         AIF   (&WSSIZE GE 20480).CK0                                   13000000
         MNOTE 16,'WS SIZE TOO SMALL, MACRO IGNORED'                    13520000
         MEXIT                                                          14040000
.CK0     AIF   (&WSSIZE EQ 36000).CK1                                   14560000
         MNOTE 0,'WARNING - NON STANDARD WORKSPACE SIZE'                15080000
.CK1     AIF   (&INCORE GT 1).CK3                                       15600000
         MNOTE 16,'INCORE MAY NOT BE LESS THAN 2, MACRO IGNORED'        16120000
         MEXIT                                                          16640000
.CK3     AIF   (&DIRS GT 1).CK4                                         17160000
         MNOTE 16,'DIRS MAY NOT BE LESS THAN 2, MACRO IGNORED'          17680000
         MEXIT                                                          18200000
.CK4     AIF   (&IODEBUG GT 0).CK5                                      18720000
         MNOTE 16,'IODEBUG MAY NOT BE LESS THAN 1, MACRO IGNORED'       19240000
         MEXIT                                                          19760000
.CK5     AIF   ('&HOST' EQ 'DOS' OR '&HOST' EQ 'APL' OR '&HOST' EQ 'OS'*20280000
                OR '&HOST' EQ 'CP67').CK6                               20800000
         MNOTE 16,'HOST SPECIFICATION INVALID, MACRO IGNORED'           21320000
         MEXIT                                                          21840000
.CK6     ANOP                                                           22360000
&DOS     SETB  ('&HOST' EQ 'DOS' OR '&HOST' EQ 'OS')                    22880000
&OS      SETB  ('&HOST' EQ 'OS')                                        23400000
&CP67    SETB  ('&HOST' EQ 'CP67')                                      23920000
&S       SETC  'ADC*'(1+&DOS+2*&CP67,1)                                 24440000
         AIF   (&OS).OSCM                                               24960000
         MNOTE *,'5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972'           25480000
         AGO   .DOSC                                                    26000000
.OSCM    MNOTE *,'5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972'           26520000
.DOSC    ANOP                                                           27040000
         AIF   (&OS).NOPC                                               27560000
         PUNCH ' CATALR APLSLINK,1.1 '                             C053 28080000
         AIF   (&DOS).INCL3                                             28600000
         PUNCH ' PHASE   APLSLOW,+0,NOAUTO                           '  29120000
         PUNCH ' INCLUDE APL&S.ASUP,(APLSUP) '                          29640000
         AIF   (&DOSEND GT X'37D0').BIGSUP                              30160000
         PUNCH ' PHASE   APL360,*+249,NOAUTO                          ' 30680000
         AGO   .SMALSUP                                                 31200000
.BIGSUP  PUNCH ' PHASE APL360,S,NOAUTO '                                31720000
.SMALSUP PUNCH ' INCLUDE APLSCONF,(COIBM) '                             32240000
         PUNCH ' INCLUDE APL&S.ASUP,(PERDEVXG,HDIR,HTAB) '              32760000
         AGO   .INCL4                                                   33280000
.INCL3   PUNCH ' INCLUDE APLSCONF,(COIBM) '                             33800000
         PUNCH ' INCLUDE APL&S.ASUP,(APLSUP,PERDEVXG,HDIR,HTAB) '       34320000
.INCL4   PUNCH ' INCLUDE APLSCONF,(SOFTPARS,PERTERMG,PUBENTG,CONFIG,APL*34840000
               SVC)  '                                                  35360000
         PUNCH ' INCLUDE APL&S.TRTA '                                   35880000
         PUNCH ' INCLUDE APL&S.PCSB '                                   36400000
         PUNCH ' INCLUDE APLSXREF '                                     36920000
         PUNCH ' INCLUDE APLSAGOR '                                     37440000
         PUNCH ' INCLUDE APLSARTH '                                     37960000
         PUNCH ' INCLUDE APLSATCH '                                     38480000
         PUNCH ' INCLUDE APLSBLOW '                                     39000000
         PUNCH ' INCLUDE APLSDIOT '                                     39520000
         PUNCH ' INCLUDE APLSDPY '                                      40040000
         PUNCH ' INCLUDE APLSDQRY '                                     40560000
         PUNCH ' INCLUDE APLSDRHO '                                     41080000
         PUNCH ' INCLUDE APLSDSER '                                     41600000
         PUNCH ' INCLUDE APLSDTRA '                                     42120000
         PUNCH ' INCLUDE APLSDYIB '                                     42640000
         PUNCH ' INCLUDE APLSEPSI '                                     43160000
         PUNCH ' INCLUDE APLSERAF '                                     43680000
         PUNCH ' INCLUDE APLSFFSS '                                     44200000
         PUNCH ' INCLUDE APLSGOUT '                                     44720000
         PUNCH ' INCLUDE APLSGRAD '                                     45240000
         PUNCH ' INCLUDE APLSINDX '                                     45760000
         PUNCH ' INCLUDE APLSMDIV '                                     46280000
         PUNCH ' INCLUDE APLSMIBM '                                     46800000
         PUNCH ' INCLUDE APLSMSOP '                                     47320000
         PUNCH ' INCLUDE APLSMRIO '                                     47840000
         PUNCH ' INCLUDE APLSMTRA '                                     48360000
         PUNCH ' INCLUDE APLSOCTL '                                     48880000
         PUNCH ' INCLUDE APLSRAVL '                                     49400000
         PUNCH ' INCLUDE APLSROTR '                                     49920000
         PUNCH ' INCLUDE APLSSCOP '                                     50440000
         PUNCH ' INCLUDE APLSSLCT '                                     50960000
         PUNCH ' INCLUDE APLSSYNT '                                     51480000
         PUNCH ' INCLUDE APLSTAKE '                                     52000000
         PUNCH ' INCLUDE APLSTBCD '                                     52520000
         PUNCH ' INCLUDE APLSTPIN '                                     53040000
         PUNCH ' INCLUDE APLSVDOP '                                     53560000
         PUNCH ' INCLUDE APL&S.SINI '                                   54080000
         PUNCH ' INCLUDE APLSOPEN '                                     54600000
         PUNCH ' INCLUDE APLSCONF,(CONFINIT)'                           55120000
         PUNCH '.END                                                 '  55640000
         PUNCH ' CATALR APLUTIL,1.1 '                              C053 56160000
         PUNCH ' PHASE   APLUTIL,S+4096,NOAUTO                       '  56680000
         PUNCH ' INCLUDE APLSCONF,(COIBM,SOFTPARS) '                    57200000
         PUNCH ' INCLUDE APLSOPEN '                                     57720000
         PUNCH ' INCLUDE APLUBILL                                    '  58240000
         PUNCH ' INCLUDE APLUINST                                    '  58760000
         PUNCH ' INCLUDE APLUUREC '                                     59280000
         PUNCH ' INCLUDE APLUDISK                                    '  59800000
         PUNCH ' INCLUDE APLUTAPE                                    '  60320000
         PUNCH ' INCLUDE APLURSTR                                    '  60840000
         PUNCH ' INCLUDE APLUDUMP                                    '  61360000
         PUNCH ' INCLUDE APLUMAIN                                    '  61880000
         PUNCH ' INCLUDE APLLABEL                                    '  62400000
         PUNCH ' ENTRY   MAIN                                        '  62920000
         PUNCH '.END                                                 '  63440000
         PUNCH ' CATALR APLSCONF,1.1 '                             C053 63960000
.NOPC    ANOP                                                           64480000
         AIF   (&OS).OSC                                                65000000
COIBM    CSECT                                                          65520000
         DC    C'5736-XM6 COPYRIGHT IBM CORP 1969,1970,1972'            66040000
*                                                                   **D 66560000
         DC    C'202157'           F.E. SERVICE NUMBER             C049 67080000
         AGO   .OSC1                                                    67600000
.OSC     ANOP                                                           68120000
COIBM    CSECT                                                          68640000
         DC    C'5734-XM6 COPYRIGHT IBM CORP 1969,1970,1972'            69160000
*                                                                   **D 69680000
         DC    C'201156'           F.E. SERVICE NUMBER             C049 70200000
.OSC1    ANOP                                                           70720000
         TITLE 'C O N F I G U R A T I O N   P A R A M E T E R S'        71240000
PERTERMG CSECT                                                          71760000
PUBENTG  CSECT                                                          72280000
         DC    F'0'                AVOID CSECT OF LENGTH ZERO.          72800000
*                                                                       73320000
*        SOFTWARE PARAMETERS                                            73840000
&CACNT SETA    &INCORE             NUMBER OF WSS IN CORE SIMULTANEOUSLY 74360000
&WSLN    SETA  &WSSIZE/8*8         WORKSPACE LENGTH (DOUBLEWORD)        74880000
&MANHASH SETA &DIRS                NUMBER OF DIRECTORIES.               75400000
*                                                                       75920000
&PADR    SETA  0-100                                                    76440000
&MDEV    SETA  4                                                        76960000
DC       EQU   X'80'                                                    77480000
CC       EQU   X'40'                                                    78000000
SLI      EQU   X'20'                                                    78520000
EMPT3    EQU   X'800000'                                                79040000
EMPTYM   EQU   X'80'                                                    79560000
F        EQU   256                                                      80080000
SAD0     EQU   X'13'                                                    80600000
SAD1     EQU   X'17'                                                    81120000
SAD2     EQU   X'1B'                                                    81640000
SAD3     EQU   X'1F'                                                    82160000
NOP      EQU   X'03'                                                    82680000
QTS41    EQU   4                                                        83200000
Q2741    EQU   24                                                       83720000
QAMBIG   EQU   44                                                       84240000
Q1050    EQU   64                                                       84760000
Q1052    EQU   84                                                       85280000
QAUX     EQU   104                                                      85800000
WRITES   EQU   0                                                        86320000
IDLE     EQU   3                                                        86840000
READS    EQU   4                                                        87360000
EXPLIM   EQU   &EXPLIM*60*300                                           87880000
WSLENR   EQU   ((&WSLN+2047)/2048)*2048                                 88400000
PERTERML EQU   120                                                      88920000
PUBENTL  EQU   20                                                       89440000
PERCOREL EQU   8                                                        89960000
CONFIG   CSECT                                                          90480000
         ENTRY MPXCUTAB                                                 91000000
*        FOR FORMAT OF MPXCUTAB SEE MPXINT IN APLSUP                    91520000
MPXCUTAB DC    32F'0'              UNIT ADDRESS TO PERTERM MAP          92040000
         DC    4A(0)                                                    92560000
         ENTRY SOOKTXT,SOOKEXTX,IODBUGG,IODBUGZ                         93080000
SOOKTXT  DC    H'19'                                                    93600000
         DC    FL4'-1617389416,1452828056,1637356696,-1885826408'       94120000
         DC    FL4'-1935696739'                                         94640000
SOOKEXTX DC    H'27'                                                    95160000
         DC    FL4'-1617389416,1452828056,1637356696,-1885826408'       95680000
         DC    FL4'-1936172435,1701272168,1755290781'                   96200000
IODBUGG  DS    (&IODEBUG)XL10'00'  I/O DEBUG TRACE TABLE                96720000
IODBUGZ  EQU   *                   END OF IODBUGG TABLE                 97240000
         EJECT                                                          97760000
         APLDEV 0,TYPE=AUX                                              98280000
         MEND                                                           98800000
./  ADD    NAME=APLSEND
         MACRO                                                          00940000
         APLSEND &MAP=254,&QEND=,&INIT=,&FMSK=                          01880000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02820000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  03760000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       04700000
         GBLA  &MDEV,&PADR,&CACNT,&WSLN,&TCNT,&MANHASH,&MINB            05640000
         GBLA  &MPXCH                                              5991 06580000
         GBLB  &DOS,&OS,&CP67                                           07520000
         GBLC  &PN                                                      08460000
         LCLA  &I                                                       09400000
*                                                                       10340000
         AIF   (NOT &OS).NOTOS                                          11280000
         APLDS   ,                 DUMMY FINAL APLDS CALL               12220000
.NOTOS   ANOP                                                           13160000
*                                                                       14100000
         APLDEV  X'100',TYPE=END                                        15040000
*                                                                       15980000
         EXTRN APLSUP,MPXSAVE,EXTIM2,APLSETLO,IM                        16920000
         ENTRY PERCOREG,PERDISKG,PERDISKZ,FREE3,CONFSWAP                17860000
&I       SETA  0                                                        18800000
PERCOREG DC    0D'0'                                                    19740000
.I1      DC    H'0'                PCQUONT                              20680000
         DC    AL3(IM+&I*WSLENR,EMPT3)                                  21620000
&I       SETA  &I+1                                                     22560000
         AIF   (&I LT &CACNT).I1                                        23500000
PERDISKG DC    0D'0'                                                    24440000
         DC    (&TCNT+5)A(0,EMPT3)     PDDA,PDTERM                      25380000
PERDISKZ EQU   *-4                                                      26320000
FREE3    DC    0D'0'                                                    27260000
IETBRN   EQU   6                                                        28200000
         DC    3A(EMPT3)           INITIAL VALUE OF FREE SP LIST        29140000
         DC    A(IETBRN*F*F*F+APLSETLO,*+8,1)  INTERVAL EVENT LIST HEAD 30080000
         DC    (&TCNT+5)A(IETBRN*F*F*F+EXTIM2,*+8,1) DUMMY IE           31020000
&I       SETA  1                                                        31960000
.I4      DC    A(ATERM&I,*+8,1)              MPX INTERVAL EVENT         32900000
&I       SETA  &I+1                                                     33840000
         AIF   (&I LT &TCNT).I4                                         34780000
         DC    A(IETBRN*F*F*F+EXTIM2,EMPT3,1)  LAST DUMMY EVENT         35720000
CONFSWAP DC    0D'0'                                                    36660000
         DC    X'01'                                                    37600000
         DC    A(SWAPPARS)                                              38540000
         DC    A(&TCNT+2)          WORKSPACES NEEDED                    39480000
.*       NOTE THAT TCNT INCLUDES A DUMMY APLDEV CALL                    40420000
         DC    A(PERDISKG)                                              41360000
         DC    F'8'                PERDISK INCREMENT                    42300000
&MINB    SETA  20+&TCNT*(5+15*&CP67)                                    43240000
OVERBOOK EQU   3       FAIRSHARE IS COMPUTED FROM THIS * ORIG FREE COUN 44180000
CONFINIT APLSUPC                                                        45120000
VALCON   EQU   ALEN+&DOS+2*&OS                                          46060000
SOFTPARS CSECT                                                          47000000
         AIF   (&OS).NOTDOS                                             47940000
         APLDS ,                   DUMMY FINAL APLDS CALL               48880000
.NOTDOS  ENTRY CCWAR,DIRTAB,KMANHASH,RD1DA,WSLEN                        49820000
* * * * * * * *ASSUMES 2311 IS DEVICE WITH SHORTEST TRACK * * * * * * * 50760000
CCWAR     DS    ((&WSLN+3599)/3600*4+2)D                                51700000
RD1DA    EQU   *+2                                                      52640000
* * * * * * * * RD1DA+2  MUST BE ON A WORD BOUNDARY * * * * * * * * *   53580000
         DC    ((&WSLN+3599)/3600+1)H'256,0,0,0'                        54520000
KMANHASH DC    A(&MANHASH)                                              55460000
WSLEN    DC    A(&WSLN)                                                 56400000
DIRTAB   DS    (2*&MANHASH+1)F     1 WORD OF SLOP NEEDED BY OPLIB       57340000
         AIF   (T'&MAP EQ 'O').NTE1                                     58280000
         AIF   (&MAP GT 255).NTE2                                       59220000
APLSVC   CSECT                                                          60160000
         ENTRY APLMAP                                                   61100000
APLMAP   EQU   APLSVC+&MAP*X'10000'                                     62040000
         ENTRY MPXCH                                               5991 62980000
MPXCH    EQU   APLSVC+&MPXCH*X'10000'                              5991 63920000
         DC    F'0'  AVOID ZERO LENGTH CSECT                            64860000
         AIF   (&OS).OSCODE                                             65800000
         MEXIT                                                          66740000
.OSCODE  ANOP                                                           67680000
.*                                                                      68620000
         AIF   (T'&FMSK NE 'O' OR T'&QEND NE 'O').NTE4                  69560000
.CONTIN  ANOP                                                           70500000
         AIF   (T'&INIT EQ 'O').NTE1                                    71440000
         AIF   (&INIT GT 255).NTE2                                      72380000
         AIF   (&INIT EQ &MAP).NTE3                                     73320000
         ENTRY APLINIT                                                  74260000
APLINIT  EQU   APLSVC+&INIT*X'10000'                                    75200000
         SPACE 3                                                        76140000
         MNOTE *,'LIST OF APL LOAD MODULE  AND  ENTRY POINT NAMES' C056 77080000
         MNOTE *,'              APL360            APLOS          ' C056 78020000
         MNOTE *,'              APLSINIT          SUPINI         ' C056 78960000
         MNOTE *,'              APLUTIL           MAIN           ' C056 79900000
         SPACE 3                                                        80840000
         MNOTE *,' LINKAGE EDITOR CONTROL CARDS FOR NUCLEUS LINKEDIT'   81780000
         MNOTE *,'  '                                                   82720000
         MNOTE *,' CHANGE IGCINIT(IGC&INIT),IGCMAP(IGC&MAP)'            83660000
         MNOTE *,' INCLUDE RESMODS(APLSMVT1)     FOR MVT, OMIT FOR MFT' 84600000
         MNOTE *,' INCLUDE RESMODS(APLSMFT1)     FOR MFT, OMIT FOR MVT' 85540000
         MEXIT                                                          86480000
.NTE1    MNOTE 16,'SYMBOLIC PARAMETER(S) UNDEFINED'                     87420000
         MEXIT                                                          88360000
.NTE2    MNOTE 16,'SYMBOLIC PARAMETER(S) OUT OF RANGE'                  89300000
         MEXIT                                                          90240000
.NTE3    MNOTE 16,'SYMBOLIC PARAMETER(S) NOT UNIQUE'                    91180000
         MEXIT                                                          92120000
.NTE4    MNOTE *,' SVCS FMSK AND QEND NOT NEEDED -- IGNORED'            93060000
         MNOTE *,'* * * * * * * * * * * * * * * * * * * *'              94000000
         MNOTE *,'* * * YOU MUST RELINKEDIT YOUR NUCLEUS * * *'         94940000
         MNOTE *,'* * * FOR THIS VERSION OF APL          * * *'         95880000
         MNOTE *,'* * * * * * * * * * * * * * * * * * * *'              96820000
         AGO   .CONTIN                                                  97760000
         MEND                                                           98700000
./  ADD    NAME=APLSUPC
         MACRO                                                          01330000
&L       APLSUPC                                                        02660000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  03990000
.*                5736-XM6 COPYRIGHT IBM CORP. 1969, 1970               05320000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       06650000
         GBLA  &CACNT,&MANHASH,&WSLN,&MINB                              07980000
         GBLB  &DOS,&OS,&CP67                                      C058 09310000
*        APLSUP, SUPINI, CONFIG COMMUNICATION REGION                    10640000
         AIF   ('&L' EQ '').A5     NO LABEL MEANS DSECT IN OTHER ASSMB  11970000
         AIF   ('&L' EQ 'SUPPARD').A1                                   13300000
         AIF   ('&L' EQ 'CONFINIT').A4                                  14630000
         ENTRY &L                                                       15960000
&L       DC    0F'0'                                                    17290000
         AGO   .A2                                                      18620000
.A5      ANOP                                                           19950000
SUPPARD  DSECT                                                          21280000
APLSUP   EQU   0                   AVOID UNDEF FLAG                     22610000
PERCOREL EQU   8                   AVOID UNDEF FLAG                     23940000
         AGO   .A6                                                      25270000
.A4      ANOP                                                           26600000
&L       CSECT                                                          27930000
         AGO   .A3                                                      29260000
.A1      ANOP                                                           30590000
&L       DSECT                     ,THIS IS SUPINI                      31920000
.A6      ANOP                                                           33250000
EXPLIM   EQU   0                   AVOID UNDEF FLAG                     34580000
.A2      ANOP                                                           35910000
PERTERMG EQU   1                   AVOID UNDEF FLAG                     37240000
PERCOREG EQU   1                   AVOID ERROR MESS                     38570000
TERMCOUN EQU   1                   AVOID ERROR MESS                     39900000
PERDISKG EQU   1                   AVOID ERROR MESS                     41230000
PERDISKZ EQU   1                   AVOID ERROR MESS                     42560000
OVERBOOK EQU   2                   NOMINAL VALUE, CONFIG CONTROLS       43890000
.A3      ANOP                                                           45220000
LSUPC    DC    A(VALCON)           FOR VERSION VALIDATION               46550000
PTBXLE   DC    A(PERTERML)         FOR ITERATION ON PERTERM             47880000
         DC    A(PERTERMG+PERTERML*(TERMCOUN-1))  LAST PERTERM          49210000
         DC    A(PERTERMG)         FIRST PERTERM                        50540000
PDBXLE   DC    F'8'                LENGTH OF PERDISK DSECT              51870000
MAXARM   DC    A(PERDISKZ)         LIMIT OF DISK SWAP SEARCH            53200000
ARM      DC    A(PERDISKG)         CURRENT ARM POSITION                 54530000
         DC    A(PERDISKG)         START OF PERDISK                     55860000
PCBXLE   DC    A(PERCOREL)         LENGTH OF PERCORE                    57190000
         DC    A(PERCOREG+(&CACNT-1)*PERCOREL)  LAST PERCORE            58520000
         DC    A(PERCOREG)         FIRST PERCORE                        59850000
SLOTS    DC    A(&CACNT)           NUMBER OF CORE SLOTS                 61180000
RRCORE   DC    A(PERCOREG)         VARAIBLE USED AS QZA2                62510000
TERMMAX  DC    A(TERMCOUN)                                              63840000
WLEN     DC    A(&WSLN)            WORKSPACE LENGTH                     65170000
COPLIM   DC    Y(3)                MAX SIMULTANEOUS )LIB OPERATIONS     66500000
SYSPARS  DC    AL1(B'&DOS.&OS.&CP67.00000',0) SYSTEM PARAMETERS    C058 67830000
KMHASH   DC    A(&MANHASH)         MANHASH FOR COMPUTING DIRECTORY NUM  69160000
KOVERBOK DC    A(OVERBOOK)         ADJUSTED BY SUPINI                   70490000
REALTIME DC    F'0'                LOW ORDER BIT = 3.33 MILLISECONDS    71820000
SVBASE   DC    A(MPXSAVE)          BASE REG FOR MPX AND SVC CODE        73150000
PTBASE   DC    A(0)                PERTERM ADDR OF GUY WE ARE RUNNING   74480000
CURRENTM DC    A(0)                WORKSP  ADDR OF GUY WE ARE RUNNING   75810000
APLBASE  DC    A(APLSUP)           NON-STANDALONE R14 SETTING           77140000
FREEBA   DC    A(0)                HEAD OF FREE BUFFER CHAIN            78470000
FREEBC   DC    F'0'                COUNT OF FREE BUFFERS                79800000
ACTKEY   DC    X'40'               KEY FOR ACTIVE WS AND INTRP          81130000
INACTKEY DC    X'30'               KEY FOR INACTIVE WS                  82460000
         DC    H'0'                UNUSED                               83790000
ALEN     EQU   *-PTBXLE            LENGTH OF MOVE                       85120000
         AIF   ('&SYSECT' EQ 'APLSUP').AZ                               86450000
*        FOLLOWING VALUES ARE FOR SUPINI & CONFINIT ONLY                87780000
AWSLENR  DC    A(WSLENR)           2048*CEIL WSLENGTH DIV 2048          89110000
KMINBUF  DC    F'&MINB'            MINIMUM TYPEWRITER BUFFERS           90440000
KEXPLIM  DC    A(EXPLIM)           EXPRESS TIME LIMIT                   91770000
         AIF   ('&L' EQ 'CONFINIT').AZ                                  93100000
WSLENR   EQU   0*2048              CONFIG WILL DEFINE                   94430000
MINBUF   EQU   0                   CONFIG WILL DEFINE                   95760000
MPXSAVE  EQU   1                   SUPINI DOESN'T NEED TO KNOW          97090000
.AZ      MEND                                                           98420000
./  ADD    NAME=COIBM
         MACRO                                                          08330000
         COIBM &ID                                                      16660000
.*    THIS IS A DEVELOPMENT MACRO.  THE MACRO IS REPLACED BY A          24990000
.*    CURRENT COPYRIGHT STATEMENT BY THE SPLIT-UP PROGRAM               33320000
         AIF   ('&ID' NE '5734').A                                      41650000
*  5734-XM6  IBM CONFIDENTIAL                                           49980000
         AGO .B                                                         58310000
.A       AIF   ('&ID' NE '5736').B                                      66640000
*  5736-XM6 IBM CONFIDENTIAL                                            74970000
.B       ANOP                                                           83300000
         MEND                                                           91630000
./  ADD    NAME=APLDEFN
 TITLE 'A P L D E F N  --  G L O B A L   D E F I N I T I O N S'         00420000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00840000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01260000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01680000
UVR      EQU   0                                                        02100000
MFMT     EQU   0                                                        02520000
MR       EQU   11                  BASE REGISTER FOR M-ARRAY            02940000
PR       EQU   12                  BASE REGISTER FOR PROGRAM            03360000
LR       EQU   13                  BASE REGISTER FOR LOCAL VARIABLES    03780000
TLR      EQU   14                  TOP OF SPACE NEEDED FOR LOCAL VARBS  04200000
LKR      EQU   15                  LINK REGISTER                        04620000
STLENGTH EQU   2048                LENGTH OF SYMBOL TABLE               05040000
         USING M,MR                                                     05460000
MEMORY   DSECT                                                          05880000
M        DS    0X                                                       06300000
REGSV    DS    16F                 SUPERVISOR REGISTER SAVE AREA        06720000
FRSAVE   DS    5D                  FLOATING REGISTERS AND SVC OLD PSW   07140000
VVMM     DS    F                   VERSION, MOD. LVL (ONLY IN DIR) C059 07560000
NUMDIRS  DS    F                   NO. OF DIRECTORIES (ONLY IN DIR)C059 07980000
         DS    4F                  UNUSED                          C059 08400000
LR13STK  EQU   1000                LENGTH OF R13 STACK                  08820000
QR13STK  DC    A(36000-LR13STK)    BOTTOM OF R13 STACK                  09240000
QSYMBOT  DC    A(36000-LR13STK-STLENGTH) BOTTOM OF SYMBOL TABLE         09660000
MX       DC    A(0)                FIRST FREE STORAGE LOCATION POINTER  10080000
SVI      DC    A(0)                'TOP' OF STACK POINTER               10500000
PARREL   DC    A(0)                OFFSET TO TOP ENTRY IN EXEC STACK    10920000
ONADRS   EQU   *-64                                                     11340000
ONXOF    DC    2A(0)               FIXED OVERFLOW ERROR ADDRESS         11760000
ONXDZ    DC    2A(0)               FIXED ZERO-DIVIDE ERROR ADDRESS      12180000
         DS    4A                  DECIMAL OVERFLOW, DIVIDE             12600000
ONFP     DC    2A(0)               FLOATING OVERFLOW ERROR ADDRESS      13020000
*                                  FOLLOWING OVERLAP UNUSED FP CHECKS   13440000
CARRPOS  DC    F'0'                CURRENT CARRIER POSITION        3587 13860000
         DS    A                   UNSED                           3587 14280000
ONATTN   DC    2A(0)               CPULIM OR DOUBLE ATTENTION SIGNAL    14700000
ONDZ     DC    2A(0)               ZERO-DIVIDE ERROR ADDRESS            15120000
ONRNG    DC    2A(0)               RANGE ERROR ADDRESS                  15540000
MQCELL   BCR   0,0                 SVC YYQZ WHEN QUANTUM END NEEDED     15960000
         DS    1H                  UNUSED                               16380000
MPTBASE  DS    A (PERTERM)         PERTERM BASE REGISTER                16800000
*        FILE LABEL FOR SAVED WORKSPACE                                 17220000
WFLLIB   DS    F                  LIBRARY NUMBER                        17640000
WFLNAME  DS    CL12               WORKSPACE NAME                        18060000
WFLMAN   DS    F                  MAN NUMBER OF SAVER                   18480000
WFLPASS  DC    XL8'00'             )LOAD )COPY PASSWORD                 18900000
WFLDATE  DS    CL8                DATE SAVED                            19320000
WFLTIME  DS    F                   TIME SAVED                           19740000
LWFLAB   EQU   *-WFLLIB            LENGTH OF WS LABEL                   20160000
*        END OF WORKSPACE LABEL                                         20580000
         DS    2F                  UNUSED                               21000000
BAKTOG   DS    FL1                 FLAG -- WE SWALLOWED SOME SYMBOLS IN 21420000
*                                  THIS DIAGRAM, AND CAN'T GET OUT      21840000
*                                  WITHOUT VIOLATING THE NO-BACKUP RULE 22260000
*                                  BIT 0 ( A GLITCH) -- CONTROL IS NOW  22680000
*                                  IN TYPEIN, NOT SYNT.  (USED BY ERR)  23100000
NEXTOG   DS    FL1                 FLAG -- SYNTAX ANALYZER NEEDS NEXT   23520000
*                                  SYMBOL FROM CODESTRING               23940000
CLASS    DC    H'0'                CLASS OF CURRENT SYMBOL              24360000
PATH     DS    F                   SAVED ADDRESS OF CURRENT DIAG PATH   24780000
MING     DC    A(FREE-M)           ADDRESS OF LOWEST GARBAGE IN M       25200000
MINGL    DC    F'0'                NUMBER OF BYTES OF GARBAGE IN M      25620000
DIASTPTR DC    F'0'                POINTER FOR DIAGRAM STACK            26040000
         DS    0D                                                       26460000
RFUZZ    DC    X'00000000000003FF'                                      26880000
AFUZZ    DC    D'1E-13'                                                 27300000
IORIGIN  DC    F'1'                INDEX ORIGIN                         27720000
RNUMBER  DC    F'16807'            RANDOM NUMBER.                       28140000
UNFUZZ   DC    D'.9999999999999'                                        28560000
SPTR     DS    F                   SYMBOL TABLE POINTER OF CURRENT SYM  28980000
SYL      DS    H                   CURRENT CODE SYLLABLE  (LEFT BYTE    29400000
*                                  GARBAGE IF 8-BIT SYLLABLE)           29820000
RUNCTL   DS    FL1                 END-OF-STATEMENT CONTROL FLAGS       30240000
RCTRABIT EQU   X'80'               THIS STATEMENT IS A BRANCH           30660000
RCQEBIT  EQU   X'40'               FORCE EXIT FROM QUAD-PRIME LOOP      31080000
RCOUTBIT EQU   X'20'               EXIT TO NEAREST IMM-EX LEVEL         31500000
RCFNBIT  EQU   X'10'               THIS STATEMENT IS IN A FUNCTION      31920000
MFLKBIT  EQU   X'20'               PROTECTED FUNCTION BIT IN M-ENTRY    32340000
RCOLBIT  EQU   X'08'               WE'RE GETTING OUT OF LOCKED FNS      32760000
         DS    FL1                 UNUSED                               33180000
         DS    F                   UNUSED                               33600000
OSIGDIG  DC    F'10'               SIGNIFICANT DIGITS IN FLOATING OUT   34020000
LLLO     DS    H                   LENGTH OF LAST LINE OUT              34440000
LGCPTR   DS    H                   VALUE OF OBUFPTR BEFORE LAST CALL OF 34860000
*                                  LOUT (FOR QUAD-PRIME I/O)            35280000
DIAST    DS    500FL1              THE DIAGRAM STACK                    35700000
DFDTS    EQU   DIAST               DIR 0 -- TIMESTAMP, LAST FULL DUMP   36120000
DIDTS    EQU   DIAST+12            DIR 0 -- TIMESTAMP, LAST INC DUMP    36540000
         DS    0F                  MAKE OBUF START ON A WORD BDY        36960000
OBUFLIM  DC    H'120'                                                   37380000
OBUFPTR  DC    H'0'                                                     37800000
OBUF     DS    CL130                                                    38220000
         DS    0F                                                       38640000
FREE     EQU   *                   BASE OF FREE STORAGE IN M            39060000
*        M-LOCATIONS FOR DIRECTORY SEARCH ONLY                          39480000
*        PARAMETERS FOR MONOLITHIC FREE STORAGE ON PACK                 39900000
MANSTAR  EQU   SVI                                                      40320000
DSNXTF   EQU   MX                                                       40740000
SALVHED  DS    60A      LIST OF SCATTERED BLOCKS ON LIB PACK.           41160000
*        FORMAT IS CCHH                                            DASD 41580000
FREEDSK  DS    20F                 CFREDSK SETTINGS FOR 20 PACKS        42000000
FIRSTENT EQU   *                                                        42420000
*              RELATIVE POSITIONS OF VARIOUS BITS OF FUNCTION-CALL      42840000
*              INFORMATION IN STACK.  VALUE EQUALS OFFSET FROM PARREL.  43260000
STFREG   EQU   0                   POINTER TO PREVIOUS STACK ENTRY      43680000
*                                  BYTE 0 = 0                           44100000
STCODE   EQU   4                   BASE ADDRESS OF CODESTRING           44520000
STTRACE  EQU   4                   BYTE HOLDING TRACE AND STOP BITS     44940000
STNXTOG  EQU   9                   SAVED COPY OF NEXTOG FOR OUTER FN    45360000
STCPTR   EQU   10                  SYLLABLE POSITION WITHIN CODESTRING  45780000
STFLAGS  EQU   13                  VARIOUS FLAGS RELATING TO THIS STMT  46200000
STLINE   EQU   14                  ACTIVE LINE NUMBER IN THIS FUNCTION  46620000
STFNSPTR EQU   16                  BST ENTRY POINTER OF FUNCTION NAME   47040000
STLINK   EQU   20                  CURRENTLY UNUSED                     47460000
STSHADOW EQU   20                  POINTER TO BST ENTRY OF NAME SHADOWED47880000
                                   BY PARAMETER 0 (NONEXISTENT)         48300000
*                                  BYTE 0 = SHADOW                      48720000
STPARAM  EQU   24                  SAVED BST ENTRY OF SHADOWED NAME     49140000
STPSBIT  EQU   X'40'               PROGRAMMED STOP BIT IN STCODE WORD   49560000
STTRBIT  EQU   X'20'               TRACE BIT IN STCODE WORD             49980000
*                            BITS IN STFLAG BYTE                        50400000
STIMBIT  EQU   X'01'               IMMEDIATE-EXECUTION BIT              50820000
STSTBIT  EQU   X'02'               COMPLETE-STATEMENT-SEEN BIT          51240000
STQBIT   EQU   X'04'               CURRENTLY ACQUIRING INPUT FOR QUAD   51660000
STQPBIT  EQU   X'08'               CURRENTLY ACQUIRING INPUT FOR QUAD'  52080000
STREMBIT EQU   X'10'               COMMENT LINE (USED ONLY BY TYPEIN)   52500000
*              RELATIVE POSITIONS OF INFORMATION IN M-ENTRIES           52920000
*              ADDRESSES ARE PRESUMABLY USED WITH M-POINTER INDEX MODI- 53340000
*              FICATION.                                                53760000
         ORG   M                                                        54180000
MLIST    DS    0B                  BYTE CONTAINING LIST BIT             54600000
MGARB    DS    0B                  BYTE CONTAINING GARBAGE BIT          55020000
MHEAD    DS    A                   BACK-POINTER FROM M-ENTRY -- FIRST   55440000
*                                  WORD OF M-ENTRY.                     55860000
MCOUNT   DS    F                   FULLWORD BYTE COUNT OF THIS M-ENTRY  56280000
*              LISTS AND FUNCTIONS                                      56700000
MLSOS    DS    H                   OFFSET OF 1ST LIST POINTER (LINE 0)  57120000
MLSCT    DS    H                   COUNT OF LIST POINTERS IN LIST ENTRY 57540000
MFLINES  EQU   MLSCT               NUMBER OF LINES IN FUNCTION (HALFWD) 57960000
MFLCLS   DS    H                   NO. OF LOCALS IN FUNCTION            58380000
MLSORG   EQU   M+12                FIRST LIST POINTER IN LIST M-ENTRY   58800000
MFPARS   DS    H                   NO. OF PARAMETERS TO FN (HALFWORD)   59220000
MFCODE   DS    A                   IN FUNCTION DIRECTORY, ADDRESS OF    59640000
*                                  CODESTRING FOR LINE 0.               60060000
         ORG   MCOUNT+4                                                 60480000
*              VARIABLES AND OTHER DATA ENTRIES                         60900000
MTYPE    DS    FL1                 DATA TYPE (= 1,2,3,4)                61320000
         DS    FL1                 UNUSED                               61740000
MRANK    DS    H                   4 * RANK                             62160000
MRHO     DS    F                   FIRST WORD OF DATA ENTRY RANK VECTOR 62580000
         ORG   MCOUNT+4                                                 63000000
*              CODESTRINGS                                              63420000
MCSCNT   DS    H                   SYLLABLE BYTE COUNT                  63840000
MCSORG   DS    X                   FIRST CODESTRING SYLLABLE            64260000
         ORG   MCOUNT+4                                                 64680000
*              PRINTNAMES                                               65100000
MPNAME   DS    C                   FIRST CHARACTER OF LONG PRINT NAME   65520000
*              FOLLOWING BITS ARE IN MLIST (= MGARB (= MHEAD))          65940000
MLSTBIT  EQU   X'40'               LIST BIT IN M-ENTRY                  66360000
MGBIT    EQU   X'80'               GARBAGE BIT IN M-ENTRY               66780000
*                                                                       67200000
*              CLASSES OF TERMINAL SYMBOLS                              67620000
SHADOW   EQU   1                   SHADOWED NONLOCAL IN STACK (NOT      68040000
*                                  REALLY A TERMINAL)                   68460000
CDST     EQU   3                   CODESTRING (NOT REALLY A TERMINAL)   68880000
CONST    EQU   4                   CONSTANT OR TEMP                     69300000
VARB     EQU   5                   VARIABLE                             69720000
QUAD     EQU   VARB                QUAD                                 70140000
LBR      EQU   6                   LEFT BRACKET                         70560000
LPAR     EQU   7                   LEFT PARENTHESIS                     70980000
RBR      EQU   8                   RIGHT BRACKET                        71400000
RPAR     EQU   9                   RIGHT PARENTHESIS                    71820000
SEMIC    EQU   10                  SEMICOLON                            72240000
EOS      EQU   11                  END OF STATEMENT                     72660000
PER      EQU   12                  PERIOD OF MATRIX PRODUCT             73080000
LARROW   EQU   13                  LEFT ARROW                           73500000
RARROW   EQU   14                  RIGHT ARROW                          73920000
SLSH     EQU   15                  SLASH, BACKSLASH                     74340000
OP       EQU   16                  OPERATOR                             74760000
NULL     EQU   17                  NULL OF MATRIX PRODUCT               75180000
DFN      EQU   18                  DEFINED FUNCTION WITH PARAMETERS     75600000
DFN0     EQU   19                  DEFINED FUNCTION, NO PARAMETERS      76020000
DFNT     EQU   20                  DEFINED FUNCTION TRACE SYMBOL        76440000
GROUP    EQU   21                  GROUP NAME                           76860000
TERMSYM  EQU   22                  INCREASE TERMSYM IF NEW CLASSES ARE  77280000
*                                  ENTERED.                             77700000
*                                                                       78120000
*              TYPE CONVERSION CODES FOR FETCH                          78540000
CVBTOI   EQU   5                                                        78960000
CVBTOF   EQU   6                                                        79380000
CVITOB   EQU   7                                                        79800000
CVITOF   EQU   8                                                        80220000
CVFTOB   EQU   9                                                        80640000
CVFTOI   EQU   10                                                       81060000
*                                                                       81480000
*              ERROR TYPES                                              81900000
ESYSTEM  EQU   0                                                        82320000
EMFULL   EQU   1                                                        82740000
ESYNTAX  EQU   2                                                        83160000
EINDEX   EQU   3                                                        83580000
ERANK    EQU   4                                                        84000000
ELENGTH  EQU   5                                                        84420000
EVALUE   EQU   6                                                        84840000
ERANGE   EQU   11                                                       85260000
EDEPTH   EQU   12                                                       85680000
EINT     EQU   13                                                       86100000
ENONCE   EQU   16                                                       86520000
*                                                                       86940000
*              APL SUPERVISOR CALL CODES                                87360000
*        EQU   0                   RESERVED                             87780000
YYTYO    EQU   1                   OUTPUT TO TERMINAL                   88200000
YYTYI    EQU   2                   INPUT FROM TERMINAL                  88620000
YYEOS    EQU   3                   END OF DIRECTORY SEARCH              89040000
YYQZ     EQU   4                   QUANTUM END                          89460000
YYLEMP   EQU   5                   LOAD EMPTY WORKSPACE                 89880000
YYTRAN   EQU   6                   TRANSMIT MESSAGE TO ANOTHER PORT     90300000
*        EQU   7                   RESERVED                             90720000
YYSDR    EQU   8                   REQUEST SPECIAL DISK OPERATION       91140000
YYATOFF  EQU   9                   TURN OFF ATTENTION BIT               91560000
YYRAPE   EQU   10                  REQUEST ANOMALOUS PROTECT EXCEPTION  91980000
YYOFF    EQU   11                  SIGN-OFF DISCONNECT PHONE CONNECTION 92400000
YYBROAD  EQU   12                  BROADCAST PA MESSAGE                 92820000
YYSOOK   EQU   13                  SIGN ON OKAY                         93240000
YYLIBZ   EQU   14                  END OF )LIB COMMAND                  93660000
YYHI     EQU   15                  SETUP )HI MESSAGE                    94080000
YYREC    EQU   16                  RECEIVE MESSAGES                     94500000
*        EQU   17                  RESERVED                             94920000
YYDEL    EQU   18                  DELAY FOR TIME INTERVAL              95340000
YYBOUN   EQU   19                  BOUNCE USER OFF SYSTEM               95760000
YYRSET   EQU   20                  RESET 2702 LINE                      96180000
YYTIME   EQU   21                  TIME OF DAY (CP/67 ONLY)             96600000
YYOFFH   EQU   22                  SIGN OFF HOLD PHONE CONNECTION       97020000
YYBREL   EQU   23                  INPUT BUFFER RELEASE                 97440000
YYEOD    EQU   24                  INITIATE SHUTDOWN OF APL             97860000
YYLOG    EQU   25                  TRANSMIT MESSAGE TO RECORDING TERM   98280000
*                                                                       98700000
         EXTRN APLMAP              BASE OF SVC-DEFINING CSECT           99120000
         EXTRN APLSVC         ALL SVC'S = APLMAP-APLSVC                 99540000
./  ADD    NAME=APLSUPC
         MACRO                                                          01330000
&L       APLSUPC                                                        02660000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  03990000
.*                5736-XM6 COPYRIGHT IBM CORP. 1969, 1970               05320000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       06650000
         GBLA  &CACNT,&MANHASH,&WSLN,&MINB                              07980000
         GBLB  &DOS,&OS,&CP67                                      C058 09310000
*        APLSUP, SUPINI, CONFIG COMMUNICATION REGION                    10640000
         AIF   ('&L' EQ '').A5     NO LABEL MEANS DSECT IN OTHER ASSMB  11970000
         AIF   ('&L' EQ 'SUPPARD').A1                                   13300000
         AIF   ('&L' EQ 'CONFINIT').A4                                  14630000
         ENTRY &L                                                       15960000
&L       DC    0F'0'                                                    17290000
         AGO   .A2                                                      18620000
.A5      ANOP                                                           19950000
SUPPARD  DSECT                                                          21280000
APLSUP   EQU   0                   AVOID UNDEF FLAG                     22610000
PERCOREL EQU   8                   AVOID UNDEF FLAG                     23940000
         AGO   .A6                                                      25270000
.A4      ANOP                                                           26600000
&L       CSECT                                                          27930000
         AGO   .A3                                                      29260000
.A1      ANOP                                                           30590000
&L       DSECT                     ,THIS IS SUPINI                      31920000
.A6      ANOP                                                           33250000
EXPLIM   EQU   0                   AVOID UNDEF FLAG                     34580000
.A2      ANOP                                                           35910000
PERTERMG EQU   1                   AVOID UNDEF FLAG                     37240000
PERCOREG EQU   1                   AVOID ERROR MESS                     38570000
TERMCOUN EQU   1                   AVOID ERROR MESS                     39900000
PERDISKG EQU   1                   AVOID ERROR MESS                     41230000
PERDISKZ EQU   1                   AVOID ERROR MESS                     42560000
OVERBOOK EQU   2                   NOMINAL VALUE, CONFIG CONTROLS       43890000
.A3      ANOP                                                           45220000
LSUPC    DC    A(VALCON)           FOR VERSION VALIDATION               46550000
PTBXLE   DC    A(PERTERML)         FOR ITERATION ON PERTERM             47880000
         DC    A(PERTERMG+PERTERML*(TERMCOUN-1))  LAST PERTERM          49210000
         DC    A(PERTERMG)         FIRST PERTERM                        50540000
PDBXLE   DC    F'8'                LENGTH OF PERDISK DSECT              51870000
MAXARM   DC    A(PERDISKZ)         LIMIT OF DISK SWAP SEARCH            53200000
ARM      DC    A(PERDISKG)         CURRENT ARM POSITION                 54530000
         DC    A(PERDISKG)         START OF PERDISK                     55860000
PCBXLE   DC    A(PERCOREL)         LENGTH OF PERCORE                    57190000
         DC    A(PERCOREG+(&CACNT-1)*PERCOREL)  LAST PERCORE            58520000
         DC    A(PERCOREG)         FIRST PERCORE                        59850000
SLOTS    DC    A(&CACNT)           NUMBER OF CORE SLOTS                 61180000
RRCORE   DC    A(PERCOREG)         VARAIBLE USED AS QZA2                62510000
TERMMAX  DC    A(TERMCOUN)                                              63840000
WLEN     DC    A(&WSLN)            WORKSPACE LENGTH                     65170000
COPLIM   DC    Y(3)                MAX SIMULTANEOUS )LIB OPERATIONS     66500000
SYSPARS  DC    AL1(B'&DOS.&OS.&CP67.00000',0) SYSTEM PARAMETERS    C058 67830000
KMHASH   DC    A(&MANHASH)         MANHASH FOR COMPUTING DIRECTORY NUM  69160000
KOVERBOK DC    A(OVERBOOK)         ADJUSTED BY SUPINI                   70490000
REALTIME DC    F'0'                LOW ORDER BIT = 3.33 MILLISECONDS    71820000
SVBASE   DC    A(MPXSAVE)          BASE REG FOR MPX AND SVC CODE        73150000
PTBASE   DC    A(0)                PERTERM ADDR OF GUY WE ARE RUNNING   74480000
CURRENTM DC    A(0)                WORKSP  ADDR OF GUY WE ARE RUNNING   75810000
APLBASE  DC    A(APLSUP)           NON-STANDALONE R14 SETTING           77140000
FREEBA   DC    A(0)                HEAD OF FREE BUFFER CHAIN            78470000
FREEBC   DC    F'0'                COUNT OF FREE BUFFERS                79800000
ACTKEY   DC    X'40'               KEY FOR ACTIVE WS AND INTRP          81130000
INACTKEY DC    X'30'               KEY FOR INACTIVE WS                  82460000
         DC    H'0'                UNUSED                               83790000
ALEN     EQU   *-PTBXLE            LENGTH OF MOVE                       85120000
         AIF   ('&SYSECT' EQ 'APLSUP').AZ                               86450000
*        FOLLOWING VALUES ARE FOR SUPINI & CONFINIT ONLY                87780000
AWSLENR  DC    A(WSLENR)           2048*CEIL WSLENGTH DIV 2048          89110000
KMINBUF  DC    F'&MINB'            MINIMUM TYPEWRITER BUFFERS           90440000
KEXPLIM  DC    A(EXPLIM)           EXPRESS TIME LIMIT                   91770000
         AIF   ('&L' EQ 'CONFINIT').AZ                                  93100000
WSLENR   EQU   0*2048              CONFIG WILL DEFINE                   94430000
MINBUF   EQU   0                   CONFIG WILL DEFINE                   95760000
MPXSAVE  EQU   1                   SUPINI DOESN'T NEED TO KNOW          97090000
.AZ      MEND                                                           98420000
./  ADD    NAME=ATT
         MACRO                                                          02380000
&L       ATT   &ON=,&OFF=,&RESET=YES,&MPTBASE=,&PAON=,&PAOFF=           04760000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  07140000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  09520000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       11900000
.*       APL TERMINAL ATTENTION SIGNAL TEST AND RESET MACRO             14280000
         LCLC  &R,&LBL                                                  16660000
&R       SETC  '&MPTBASE'                                               19040000
&LBL     SETC  '&L'                                                     21420000
         AIF   (T'&MPTBASE NE 'O').ATT3                            C049 23800000
         AIF   (T'&ON NE 'O' OR T'&OFF NE 'O').ATT13               C049 26180000
         AIF   (T'&PAON EQ 'O' AND T'&PAOFF EQ 'O').ATT3           C049 28560000
.ATT13   ANOP                                                      C049 30940000
&L       L     1,MPTBASE                                                33320000
&R       SETC  '(1)'                                                    35700000
&LBL     SETC  ' '                                                      38080000
.ATT3    AIF   (T'&PAOFF EQ 'O' AND T'&PAON EQ 'O').ATT7                40460000
&LBL     TM    IOB1-PERTERM(&R),BROADM                                  42840000
&LBL     SETC  ' '                                                      45220000
         AIF   (T'&PAON EQ 'O').ATT6                                    47600000
         BO    &PAON                                                    49980000
.ATT6    AIF   (T'&PAOFF EQ 'O').ATT7                                   52360000
         BZ    &PAOFF                                                   54740000
         AIF   (T'&PAON NE 'O').ATT10                                   57120000
.ATT7    AIF   (T'&OFF EQ 'O' AND T'&ON EQ 'O').ATT8                    59500000
&LBL     TM    ACTIVE-PERTERM(&R),ATTENM                                61880000
&LBL     SETC  ' '                                                      64260000
         AIF   (T'&OFF EQ 'O').ATT11                                    66640000
         BZ    &OFF                                                     69020000
         AGO   .ATT8                                                    71400000
.ATT11   AIF   ('&RESET' EQ 'YES').ATT12                                73780000
         BO    &ON                                                      76160000
         MEXIT                                                          78540000
.ATT12   BZ    ATTX&SYSNDX                                              80920000
.ATT8    AIF   ('&RESET' NE 'YES').ATT9                                 83300000
&LBL     SVCC  YYATOFF                                                  85680000
.ATT9    AIF   (T'&ON EQ 'O').ATT10                                     88060000
         B     &ON                                                      90440000
.ATT10   ANOP                                                           92820000
ATTX&SYSNDX    EQU *                                                    95200000
         MEND                                                           97580000
./  ADD    NAME=CANCEL
         MACRO                                                          14280000
&L       CANCEL                                                         28560000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969,1970                   42840000
.*       REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083     57120000
&L       ABEND 1500,DUMP                                           C060 71400000
         MEND                                                           85680000
./  ADD    NAME=CCB
       MACRO                                                            01560000
&CCBN  CCB   &SYSXXX,&CCWADD,&OPTIONS,&SENSE                            03120000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  04680000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       06240000
       LCLA  &CLASS,&NUM                                                07800000
         LCLB  &SNS                                                     09360000
         LCLB  &DUMMY                                              C049 10920000
       LCLC  &UNIT,&CCWAD,&OPTSW,&T                                     12480000
&T SETC 'L'''                                                           14040000
.* IBM SYSTEM/360 DISK OPERATING SYSTEM                                 15600000
* 360N-CL-453 CCB      CHANGE LEVEL 3-0                                 17160000
       AIF   (T'&CCBN  NE  'O').NAMOK                                   18720000
       MNOTE 0,'POSSIBLE ERROR - NAME FIELD BLANK'                      20280000
.NAMOK AIF  (K'&SYSXXX NE 6).ERR                                        21840000
       AIF   ('&SYSXXX'(1,3)  NE  'SYS').ERR                            23400000
&UNIT  SETC  '&SYSXXX'(4,3)                                             24960000
  AIF ('&UNIT' LT '000' OR '&UNIT' GT '243').LTRS                       26520000
       AIF   ('&UNIT'(2,1)  LT  '0'  OR  '&UNIT'(2,1)  GT  '9').ERR     28080000
       AIF   ('&UNIT'(3,1)  LT  '0'  OR  '&UNIT'(3,1)  GT  '9').ERR     29640000
&CLASS SETA  1                         PROBLEM PROGRAM UNIT CLASS       31200000
&NUM   SETA  &UNIT                     NUMBER IN CLASS                  32760000
       AGO   .FND                      GO CHECK CCWADD ENTRY            34320000
.LTRS  AIF   ('&UNIT' EQ 'RDRIPTPCHLSTLOGLNKRESSLBRLB'(3*&NUM+1,3)).FND 35880000
&NUM   SETA  &NUM+1                                                     37440000
       AIF   (&NUM  LE  8).LTRS                                         39000000
.ERR MNOTE 3,'FIRST OPERAND INVALID - ''FFFF'' GENERATED'               40560000
&CLASS  SETA  255                                                       42120000
&NUM   SETA  255                       SET INVALID VALUE                43680000
.FND   ANOP                                                             45240000
&CCWAD SETC  '0'                                                        46800000
       AIF   (T'&CCWADD  EQ  'O').CCDER                                 48360000
&CCWAD SETC  '&CCWADD'                                                  49920000
&DUMMY   SETB  (T'&CCWADD EQ 'W' OR T'&CCWADD EQ 'N' OR                X51480000
               T'&CCWADD EQ 'U') TYPE MAY BE CCW, SELF-DEF OR UNDEFC049 53040000
         AIF   (&DUMMY).CKOPT                                      C049 54600000
.CCDER MNOTE 0,'POSSIBLE ERROR IN SECOND OPERAND'                       56160000
.CKOPT ANOP                                                             57720000
&OPTSW SETC  '0'                                                        59280000
       AIF   (T'&OPTIONS  EQ  'O').ASMBL                                60840000
       AIF   (K'&OPTIONS  LT  4  OR  K'&OPTIONS  GT  7).OPTER           62400000
       AIF   ('&OPTIONS'(1,2) NE 'X''' OR '&OPTIONS'(K'&OPTIONS,1) NE 'X63960000
               ''').OPTER                                               65520000
&OPTSW SETC  '&OPTIONS'(3,K'&OPTIONS-3)                                 67080000
       AGO   .ASMBL                                                     68640000
.OPTER MNOTE 3,'THIRD OPERAND INVALID - X''0000'' ASSUMED'              70200000
.ASMBL ANOP   ,                        ALL OPERAND OK - ASSEMBLE        71760000
&SNS SETB (T'&SENSE NE 'O')                                             73320000
 AIF (NOT &SNS).R2                                                      74880000
         DS    0D                                                       76440000
.R2 ANOP                                                                78000000
&CCBN  DC    XL2'0'                    RESIDUAL COUNT                   79560000
       DC    XL2'&OPTSW'               COMMUNICATIONS BYTES             81120000
       DC    XL2'0'                    CSW STATUS BYTES                 82680000
       DC    AL1(&CLASS)               LOGICAL UNIT CLASS               84240000
       DC    AL1(&NUM)                 LOGICAL UNIT                     85800000
       DC    XL1'0'                                                     87360000
       DC    AL3(&CCWAD)               CCW ADDRESS                      88920000
         DC    B'00&SNS.00000'         STATUS BYTE                      90480000
       DC    AL3(0)                    CSW CCW ADDRESS                  92040000
 AIF (NOT &SNS).R1                                                      93600000
         CCW   4,&SENSE,0,&T&SENSE                                      95160000
.R1 ANOP                                                                96720000
       MEND                                                             98280000
./  ADD    NAME=CDCPARS
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            04000000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  08000000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       12000000
CDCPARS  DSECT               PARAMETERS FOR CDCOMP, TRCOMP, DSKFMT      16000000
PHYSAD   DS    XL2                 UNIT ADDRESS FOR SIO                 20000000
*                                  = X'170' FOR 2314 MAYBE              24000000
LOGAD    DS    XL2                 SYMBOLIC ADDRESS FOR CCB             28000000
*                                  = X'104' FOR SYS004                  32000000
TLENF    DS    A (TRACK LENGTH)                                         36000000
HMIN     DS    H                   ZERO EXCEPT WHEN SPLIT CYL           40000000
HMAX     DS    H  NUMBER OF HEADS/CYLINDER, (EXTUP+2)+1=SPLIT CYL  DASD 44000000
EXTLOW   DS    F                   CCHH LOWER EXTENT                    48000000
EXTUP    DS    F                   CCHH UPPER EXTENT                    52000000
CCADJ    DS    F                   (2*16)+HMIN-HMAX                     56000000
CDCFLAGS DS    X                                                   5989 60000000
RPS      EQU   X'80'                                               DASD 64000000
CDCSWAP  EQU   X'40'               THIS IS A SWAP FILE IF ON       5989 68000000
CDCNDC   EQU   X'20'               DO NOT DATA CHAIN IF ON         5989 72000000
         DS    X                   UNUSED                          5989 76000000
TPERWS   DS    H                   TRACKS PER WORKSPACE            5989 80000000
CFREDSK  DS    F                   CCHH FIRST FREE TRACK                84000000
DSLAB    DS    44C                 USED BY NOPEN IN VTOC SEARCH         88000000
CDCL     EQU   *-CDCPARS                                                92000000
*        WARNING.. THE APLDS MACRO MAKES ASSUMPTIONS ABOUT THIS DSECT   96000000
./  ADD    NAME=CDINF
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972      01250000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972      02500000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03750000
*        INFORMATION ABOUT CURRENT DISK OPERATION                       05000000
CDDISK   DS    A (PERDISK)                                              06250000
CDTERM   DS    A (PERTERM)                                              07500000
CDCORE   DS    A (PERCORE)                                              08750000
         DC    X'00'               HIGH ORDER BYTE OF CDOP HALFWORD     10000000
CDOP     DC    X'00'               OPERATION                            11250000
ONETRK   DC    X'80'               ONE-TRACK WORKSPACE FLAG.  0 IF TRUE 12500000
NOT1TRK  EQU   X'80'               NOT ONE TRACK WS                5989 13750000
INCORMV  EQU   X'40'               INCORE MOVE IS REQUIRED         5989 15000000
CCPASS   DC    X'00'                                                    16250000
EXPCSW   DC    F'0'                DISK INTERRUPT, EXPECTED CSW         17500000
         DC    X'0C000000'                                              18750000
ARLIM    DC    A(*-*)              END OF AREA                     5989 20000000
R4       DC    A(*-*)         SOURCE OR SINK FOR MVC AT RELOC      5989 21250000
         DC    A(*-*)         SINK OR SOURCE FOR MVC AT RELOC      5989 22500000
R5       DC    A(*-*)         SAVES START OF AREA2 IN CDCOMP SETUP 5989 23750000
COUNT    DC    H'256'              LENGTH FOR MVC INSTRUCTION      5989 25000000
MVCLNGTH DC    H'0'                TOTAL LENGTH OF MOVE            5989 26250000
NPCICL   EQU   X'3F'                                                    27500000
*        CCW FLAG BIT ASSIGNMENTS                                       28750000
DC       EQU   X'80'                                                    30000000
CC       EQU   X'40'                                                    31250000
PCI      EQU   X'08'                                                    32500000
SKIP     EQU   X'10'                                                    33750000
SLI      EQU   X'20'                                                    35000000
TIC      EQU   X'08'                                                    36250000
SENSE    EQU   X'04'                                                    37500000
SEEK     EQU   X'07'               IDSK COMMAND                         38750000
RDATA    EQU   6                   READ DATA COMMAND               5989 40000000
SETSECTR EQU   X'23'               SET SECTOR COMMAND FOR RPS      DASD 41250000
NOP      EQU   3                   NO OP COMMAND                   DASD 42500000
ENABLE   EQU   X'27'                                                    43750000
DISABLE  EQU   X'2F'                                                    45000000
*        PARAMETERS FOR 2311 CCW CREATION                               46250000
TLENC    DC    Y(CC*256)           HALF OF CCW                          47500000
         DC    Y(TRMAX)            MUST FOLLOW TLENC                    48750000
         DS    0D                                                       50000000
*        CCPAR1 IS SUBJECT OF LM * * * * *                              51250000
CCPAR1   DC    A(0)              ADDRESS OF CORE WORKSPACE              52500000
CCWAD    DC    A(CCWAR)                                                 53750000
*        CCW CHAIN TO READ FIRST TRACK OF WORKSPACE                     55000000
RD1ST    CCW   SEEK,RD1DA,CC,6                                          56250000
RPSCCW   CCW   SETSECTR,ZERO,CC,1  WILL BE A NO-OP IF RPS NOT USED DASD 58750000
.NORPS2  ANOP                      SIGH...                         DASD 60000000
         CCW   X'31',RD1DA+2,CC,5                                       61250000
         CCW   TIC,*-8,0,1                                              62500000
CDCAD    CCW   X'06',*-*,DC,SELARGL  READ SIZE ARGUMENTS                63750000
         CCW   0,00,CC+PCI,TRMAX-SELARGL    READ REMAINDER              65000000
RD1A     CCW   0,0,X'20',1         RD1A MAY BE EXECUTED AS..            66250000
*        CCW   TIC,CCWAR+32        NORMAL WS READ                       67500000
*        CCW   0,GARBAGE,X'20',1   IO TIMING PROBLEM, RECOVERABLE       68750000
*        CCW   3,RANDOM,X'20',1    1-TRK READ                           70000000
CCSKD    DC    X'2A000002'                                              71250000
*        CCSKD IS ADDED TO A SEEK CCW TO GENERATE A SEARCH ID EQ CCW    72500000
*              WITH THE PROPER ADDRESS                                  73750000
SELARGL  EQU   SVI+12-M            INITIAL SEGMENT OF RECORD 1          75000000
SELARGDC DC    AL1(DC,0,0,SELARGL) DATA CHAIN AND COUNT FOR CDCAD  5989 76250000
NDCCSW   DC    A(CDCAD+8)          THE ADDRESS IF NOT DATA CHAINED 5989 77500000
         DC    X'0C00'             CHANNEL END, DEVICE END         5989 78750000
         DC    H'0'                NO RESIDUAL COUNT               5989 80000000
SELBUSY  DC    X'00'               0 WHEN SELECTOR CHANNEL IS IDLE      81250000
SELFERR  DC    X'00'               1 MEANS CDCOMP FORCED ERROR          82500000
*        PHYCYL MUST BE ON A WORD BOUNDARY                         DASD 83750000
         DC    XL2'0'              BB FOR PHYCYL                   DASD 85000000
PHYCYL   DC    XL4'0'              CCHH OF FIRST TRACK             DASD 86250000
         DC    X'01'               R FOR PHYCYL                         87500000
CCFIRST  DC    X'80'               FIRST WRITE PASS SWITCH         DASD 90000000
.NORPS4  ANOP                                                      DASD 91250000
         USING CDCPARS,4                                           DASD 92500000
CC10     CLI   HMAX+1,0            EXECUTED                        DASD 93750000
         DROP  4                                                   DASD 95000000
DOP      DS    CL2                                                 DASD 96250000
TRMAX    EQU   7200                BYTES PER DISK RECORD (=TRACK)       97500000
*        END OF CDINF COPY CODE * * * * *                          DASD 98750000
./  ADD    NAME=DIRSECT
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            01920000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  03840000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       05760000
*              SPECIAL DISK OPERATION CODES                             07680000
*        ***** EVERYONE MAKES ASSUMPTIONS ON ORDERING *****             09600000
XXDROP   EQU   0                                                        11520000
XXSAVE   EQU   2                                                        13440000
XXLOAD   EQU   4                                                        15360000
XXCOPY   EQU   6                                                        17280000
XXADD    EQU   8                                                        19200000
XXLIB    EQU   10                                                       21120000
XXLEMP   EQU   12                                                       23040000
XXOFF    EQU   14                                                       24960000
XXDEL    EQU   16                                                       26880000
XXLOCK   EQU   18                                                       28800000
XXUNLK   EQU   20                                                       30720000
XXPASS   EQU   22                                                       32640000
PERLIB   DSECT                                                          34560000
LIBNUM   DS    1F                 LIB RARY NUMBER                       36480000
LIBLINK  DS    F                   POINTS TO PERSAVW ENTRY FOR WS       38400000
MANWSQ   DS    H                   QUOTA FOR )SAVE                      40320000
MANWSA   DS    H                   ACTUAL NUMBER OF SAVED WORKSPACES    42240000
CUMCON   DS    1F                 CUMULATIVE CONNECTION TIME            44160000
CUMCOM   DS    1F                 CUMULATIVE COMPUTE TIME               46080000
HISNAME  DS    CL12               REPLY TO SIGN ON MESSAGE              48000000
SOPASS   DS    XL8 '00'            SIGN ON PASS WORD                    49920000
SRALIM   DS    H 'INFINITY'        CPU EXECUTION TIME LIMIT             51840000
PLMISC   DS    H                   GARBAGE LIKE AUTO-LOAD FLAG          53760000
*              FLAGS FOR PLMISC                                         55680000
LIBAUTOL EQU   X'80'               AUTOLOAD FLAG                        57600000
LIBLOCK  EQU   X'40'               LOCKED-OUT FLAG                      59520000
         DS    2F                  RESERVED FOR FUTURE ACCOUNTING       61440000
MANENTL  EQU   *-PERLIB                                                 63360000
**********************************************************************  65280000
*        NOTE ..                                                        67200000
*        SEVERAL ROUTINES ASSUME THAT PSLINK AND LIBLINK HAVE THE       69120000
*        SAME DISPLACEMENT IN PERSAVW AND PERLIB RESPECTIVELY.          71040000
*********************************************************************** 72960000
*        IF PERLIB CHANGES, ADJUST NEWMAN IN DIRSEAR * * * * * *        74880000
*        ENTRY FORMAT, DIRECTORY OF SAVED WORKSPACES                    76800000
PERSAVW  DSECT                                                          78720000
PSCYL    DS    F                   CCHH OF FIRST TRACK             DASD 80640000
PSLINK   DS    F                   LINK TO NEXT PERSAVW                 82560000
PSNAME   DS    CL12             WORKSPACE NAME                          84480000
PSMAN    DS    1F                 MAN NUMBER FOR SAVE COMMAND           86400000
PSPASS   DS    CL8                 )LOAD  )COPY PASSWORD                88320000
PSFILE   DS    Y                   PACK NUMBER FOR MULTIPLE DISK        90240000
PSLEN    DS    XL1                 NUMBER OF TRACKS                DASD 92160000
         DS    0F                  ALIGN                                94080000
PSWL     EQU   *-PERSAVW                                                96000000
*        END OF DIRSECT COPY * * * * * * * * * * *                      97920000
./  ADD    NAME=EOJ
         MACRO                                                          11110000
&L       EOJ                                                            22220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  33330000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       44440000
&L       L     13,OSLINK                                                55550000
         LM    14,12,12(13)                                             66660000
         BR    14                                                       77770000
         MEND                                                           88880000
./  ADD    NAME=GETIME
         MACRO                                                          12500000
&L       GETIME                                                         25000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  37500000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       50000000
&L       TIME TU                                                        62500000
         SRDL  0,39                                                     75000000
         MEND                                                           87500000
./  ADD    NAME=ICALL
         MACRO                                                          05880000
&LBL     ICALL &A,&X                                                    11760000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  17640000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  23520000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       29400000
         AIF   ('&A'(1,1) EQ '(').A1                                    35280000
         AIF   ('&X' EQ '*').A2                                         41160000
&LBL     L     LKR,=A(&A)                                               47040000
         BALR  LKR,LKR                                                  52920000
         MEXIT                                                          58800000
.A1      ANOP                                                           64680000
&LBL     BALR  &A(1),LKR                                                70560000
         MEXIT                                                          76440000
.A2      ANOP                                                           82320000
&LBL     BAL   LKR,&A                                                   88200000
         MEND                                                           94080000
./  ADD    NAME=IOBECBD
         MACRO                                                          03120000
         IOBECBD                                                        06240000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  09360000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  12480000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       15600000
IOBECB   DSECT                                                          18720000
         SPACE 2                                                        21840000
IOBFLAG1 DS    C                   I/O FLAGS                            24960000
IOBFLAG2 DS    C                                                        28080000
IOBSENS0 DS    C                   USED BY SYSTEM                       31200000
IOBSENS1 DS    C                                                        34320000
IOBECBCC DS    C                   ECB COMPLETION CODE                  37440000
IOBECBPT DS    AL3                 ADDRESS OF ECB                       40560000
IOBFLAG3 DS    C                   USED BY SYSTEM                       43680000
IOBCSW   DS    7C                  LOW ORDER 7 BYTES OF CSW             46800000
IOBSTAT  EQU   IOBCSW+3                                                 49920000
IOBSIOCC DS    C                   SIO IL AND CC BITS                   53040000
IOBSTART DS    AL3                 START ADDRESS OF CHANNEL PROGRAM     56160000
IOBDCB   DS    C                   USED BY SYSTEM                       59280000
IOBDCBPT DS    AL3                 ADDRESS OF DCB                       62400000
IOBREPM  DS    C                   USED BY SYSTEM                       65520000
IOBRESTR DS    AL3                 RESTART ADDRESS FOR ERROR RECOVERY   68640000
IOBBCI   DS    H                   BLOCK COUNT INCREMENT (FOR TAPE)     71760000
IOBERRCT DS    H                   ERROR COUNT                          74880000
IOBEXTM  DS    C                   EXTENT ENTRY                         78000000
IOBSKPT  DS    7C                  SEEK ADDRESS(BBCCHHR)                81120000
         SPACE 2                                                        84240000
EVNTCB   DS    F                   EVENT CONTROL BLOCK.                 87360000
         SPACE 2                                                        90480000
&SYSECT  CSECT                                                          93600000
         MEND                                                           96720000
./  ADD    NAME=IRB
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  05550000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       11100000
IRB      DSECT                                                          16650000
RBTMFLD  DS    0CL1                                                     22200000
RBPPSAV  DS    A                                                        27750000
RBAOPSW  DS    A                   RH OLD PSW DURING ABEND.             33300000
RBWCSA   DS    C                                                        38850000
RBSIZE   DS    C                   SIZE IN DOUBLEWORDS FOR FREEMAIN.    44400000
RBSTAB   DS    H                   STATUS AND ATTRIBUTE BITS.           49950000
RBEP     DS    A                   ENTRY POINT.                         55500000
RBOPSW   DS    D                                                        61050000
RBUSE    DS    0CL1                                                     66600000
RBIQE    DS    A                   A(IQE)                               72150000
RBWCF    DS    0CL1                WAIT COUNT.                          77700000
RBLINK   DS    A                                                        83250000
RBGRS    DS    16A                 0-15.                                88800000
RBNEXAV  DS    A                   IEQLIST. NOT USED.                   94350000
./  ADD    NAME=IRETURN
         MACRO                                                          11110000
&LBL     IRETURN                                                        22220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  33330000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  44440000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       55550000
&LBL     LM    PR,LKR,0(LR)                                             66660000
         BR    LKR                                                      77770000
         MEND                                                           88880000
./  ADD    NAME=LEMP
         MACRO                                                          11110000
&L       LEMP                                                           22220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  33330000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  44440000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       55550000
*        SYSTEM DISASTER.  LOAD EMPTY WORKSPACE.                        66660000
&L       SVCC  YYLEMP              LOAD EMPTY WORKSPACE                 77770000
         MEND                                                           88880000
./  ADD    NAME=MKG
         MACRO                                                          06660000
&F       MKG   &R                                                       13320000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  19980000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  26640000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       33300000
&F       C     &R,MING                                                  39960000
         BH    *+8                                                      46620000
         ST    &R,MING                                                  53280000
         AR    &R,MR                                                    59940000
         OI    MGARB-M(&R),MGBIT                                        66600000
         L     &R,4(0,&R)                                               73260000
         A     &R,MINGL                                                 79920000
         ST    &R,MINGL                                                 86580000
         MEND                                                           93240000
./  ADD    NAME=ON
         MACRO                                                          02630000
&L       ON    &COND,&BAD                                               05260000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  07890000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  10520000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       13150000
         LCLC  &HOSA                                                    15780000
.*       ON    COND,ADDR           PRESETS THE PROGRAM-CHECK            18410000
.*             (AND PROGRAMMER-DEFINED CHECK) HANDLER TO TRANSFER CON-  21040000
.*             TROL TO 'ADDR' IF CONDITION 'COND' OCCURS.               23670000
.*             'ADDR' MAY BE EITHER AN ADDRESSABLE LOCATION OR AN       26300000
.*             ADCON LITERAL (E.G, =A(RER) ).                           28930000
.*       ON    COND                WITH NO ADDRESS RESETS THE INTERRUPT 31560000
.*             ADDRESS TO THE DEFAULT VALUE.                            34190000
.*             ON'S FOR THE SAME CONDITION CANNOT BE STACKED, AND THERE 36820000
.*             IS NO AUTOMATIC REVERT.                                  39450000
         AIF   (T'&BAD EQ 'O').ON2                                      42080000
&HOSA    SETC  '&BAD'(1,1)                                              44710000
         AIF   ('&HOSA' EQ '=').ON1                                     47340000
&L       LA    0,&BAD                                                   49970000
         AGO   .ON5                                                     52600000
.ON1     ANOP                                                           55230000
&L       L     0,&BAD                                                   57860000
.ON5     AIF   ('&COND' NE 'XOF').ON4                                   60490000
         L     1,=A(X'1000'*X'8000')                                    63120000
         SPM   1                                                        65750000
.ON4     LR    1,LR                                                     68380000
         SR    1,MR                                                     71010000
         STM   0,1,ON&COND                                              73640000
         MEXIT                                                          76270000
.ON2     AIF   ('&COND' NE 'XOF').NSPM                                  78900000
&L       SR    0,0                                                      81530000
         SPM   0                                                        84160000
.NSPM    ANOP                                                           86790000
&L       L     0,=V(DFLT&COND)                                          89420000
         L     1,QR13STK                                                92050000
         STM   0,1,ON&COND                                         C049 94680000
         MEND                                                           97310000
./  ADD    NAME=OPSECT
         TITLE 'OPERATOR EXECUTION TEMP STORAGE.'                       00800000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01600000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02400000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03200000
OPSECT   DSECT                                                          04000000
         SPACE                                                          04800000
*                                                                       05600000
*        OPERATOR CONTROL ROUTINE STORAGE.                              06400000
*                                                                       07200000
         SPACE                                                          08000000
OPERATOR DS    2F                  CURRENT OPERATOR.                    08800000
OPINDEX  EQU   OPERATOR+4                                               09600000
         SPACE                                                          10400000
TYPINFO  DS    5F                  RESULTS FROM ARTHTP.                 11200000
OPRN     EQU   TYPINFO             ROUTINE ADDRESS.                     12000000
LCTYPE   EQU   OPRN+4              LH OPERAND FETCH CODE.               12800000
RCTYPE   EQU   LCTYPE+4            RH OPERAND FETCH CODE.               13600000
RSTYPE   EQU   RCTYPE+4            RESULT TYPE.                         14400000
COMTYP   EQU   RSTYPE+4            COMPUTE TYPE.                        15200000
         SPACE                                                          16000000
INCR     DS    F                   SVI INCREMENT DURING CLEANUP.        16800000
STOP     DS    2F                  TEMP STORE INSTRUCTION.              17600000
LOP      EQU   STOP+4              TEMP LOAD INSTRUCTION.               18400000
TEMPRGT  DS    FL1                 RH TEMP INDICATOR.                   19200000
TEMPLFT  DS    FL1                 LH TEMP INDICATOR.                   20000000
LTORRT   DS    FL1                 INDICATOR OF STORAGE USED.           20800000
LHSCALAR DS    FL1                 LEFT SCALAR INDICATOR.               21600000
RHSCALAR DS    FL1                 RIGHT SCALAR INDICATOR.              22400000
BLOWN    DS    FL1                 BLOWUP INDICATOR.                    23200000
FCHSCLR  DS    FL1                 EXFETCH EXTENSION INDICATOR.         24000000
TEMPIND  DS    FL1                 INDEX TEMP INDICATOR.                24800000
         SPACE                                                          25600000
*                                                                       26400000
*        OPERAND INFORMATION.                                           27200000
*                                                                       28000000
         SPACE                                                          28800000
*        LEFT OPERAND.                                                  29600000
         SPACE                                                          30400000
LHBASE   DS    F                   M-POINTER.                           31200000
LHRANK   DS    F                   RANK.                                32000000
LHXRHO   DS    F                   NUMBER OF ELEMENTS.                  32800000
LHTYPE   DS    F                   TYPE.                                33600000
LHFETCH  DS    3F                  FETCH OPERANDS.                      34400000
LINDX    EQU   LHFETCH             ELEMENT INDEX.                       35200000
LCFTYPE  EQU   LINDX+4             FETCH CODE FROM ARTHTP.              36000000
LHORG    EQU   LCFTYPE+4           DATA ORIGIN.                         36800000
LHFROUT  DS    F                   SOP LEFT FETCH ROUTINE ADDRESS.      37600000
         SPACE                                                          38400000
*        RIGHT OPERAND.                                                 39200000
         SPACE                                                          40000000
RHBASE   DS    F                   M-POINTER.                           40800000
RHRANK   DS    F                   RANK.                                41600000
RHXRHO   DS    F                   NUMBER OF ELEMENTS.                  42400000
RHTYPE   DS    F                   TYPE.                                43200000
RHFETCH  DS    3F                  FETCH OPERANDS.                      44000000
RINDX    EQU   RHFETCH             ELEMENT INDEX.                       44800000
RCFTYPE  EQU   RINDX+4             FETCH CODE FROM ARTHTP.              45600000
RHORG    EQU   RCFTYPE+4           DATA ORIGIN.                         46400000
RHFROUT  DS    F                   SOP RIGHT FETCH ROUTINE ADDRESS.     47200000
         SPACE                                                          48000000
*        INDEX.                                                         48800000
INDBASE  DS    F                   1ST BYTE 0 IF NO INDEX               49600000
INDRANK  DS    F                   RANK.                                50400000
INDXRHO  DS    F                   NUMBER OF ELEMENTS.                  51200000
INDTYPE  DS    F                   TYPE.                                52000000
INDEX    DS    F                   HOLD INDEX, IF SCALAR.               52800000
         SPACE                                                          53600000
*        RESULT.                                                        54400000
         SPACE                                                          55200000
RBASE    DS    F                   M-POINTER.                           56000000
RRANK    DS    F                   RANK.                                56800000
RXRHO    DS    F                   NUMBER OF ELEMENTS.                  57600000
RRTYPE   EQU   RSTYPE              TYPE.                                58400000
RESTORE  DS    3F                  STORE OPERANDS.                      59200000
RESINDX  EQU   RESTORE             ELEMENT INDEX.                       60000000
RESTYPE  EQU   RESINDX+4           TYPE.                                60800000
RESORG   EQU   RESTYPE+4           DATA ORIGIN.                         61600000
         SPACE                                                          62400000
*        BOOLEAN STORE OPERANDS.                                        63200000
         SPACE                                                          64000000
GEARSHFT DS    3F                                                       64800000
TEMPRES  EQU   GEARSHFT                                                 65600000
CURRES   EQU   TEMPRES+4                                                66400000
STRSHIFT EQU   CURRES+4                                                 67200000
         SPACE                                                          68000000
*                                                                       68800000
*        EXECUTION ROUTINE SCRATCH STORAGE.                             69600000
*        ROUTINES MAKE ASSUMPTIONS ABOUT ORDERING.                      70400000
*                                                                       71200000
         SPACE                                                          72000000
FACTSAVE DS    F                                                        72800000
BINSAVE  DS    F                                                        73600000
BSIGN    DS    F                                                        74400000
BINOSAVE DS    F                                                        75200000
DBISAVE  DS    F                                                        76000000
DBINSAVE DS    F                                                        76800000
FBINSAVE DS    F                                                        77600000
FTEMP    DS    F                                                        78400000
HOLDRITE DS    F                                                        79200000
REGSAV   DS    F                                                        80000000
RESSIGN  DS    F                                                        80800000
RITEHOLD DS    F                                                        81600000
SAVEMALL DS    5F                                                       82400000
SAVER    DS    F                                                        83200000
TESTAREA DS    F                                                        84000000
XORWORD  DS    F                                                        84800000
A        DS    D                                                        85600000
B        DS    D                                                        86400000
BILSAVE  DS    D                                                        87200000
BIRSAVE  DS    D                                                        88000000
BISAVE   DS    D                                                        88800000
C        DS    D                                                        89600000
DBLHOLD  DS    D                                                        90400000
DBLSAVE  DS    D                                                        91200000
DSTORE   DS    D                                                        92000000
DSAVE    DS    D                                                        92800000
DTEMP    DS    D                                                        93600000
LHSAVE   DS    D                                                        94400000
RHSAVE   DS    D                                                        95200000
RSAVE    DS    D                                                        96000000
XTNSHN   DS    D                                                        96800000
P        DS    FL1                                                      97600000
         SPACE                                                          98400000
NDOPSECT EQU   *                                                        99200000
./  ADD    NAME=PERTERM
         TITLE 'P E R T E R M -- G L O B A L   D E F I N I T I O N S'   00730000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01460000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02190000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       02920000
PERTERM  DSECT                                                          03650000
*        ALWAYS IN CORE AREA FOR EACH POSSIBLE TERMINAL                 04380000
*        CONTAINS FLAGS AND POINTERS FOR SCHEDULER AND INTERPRETER.     05110000
*        INITIAL TYPEWRITER CCW'S ARE HERE.                             05840000
PTTYPE   DS    XL1               DEVICE TYPE  1052,2741, ETC            06570000
*        NOTE THAT PTTYPE=0 MEANS THAT THE 3 FOLLOWING BYTES GIVE THE   07300000
*        TRUE PUBENT ADDRESS FOR THIS DEVICE ADDRESS                    08030000
*        IF PTTYPE & 3 FOLLOWING BYTES = 0, THIS IS A DUMMY ENTRY.      08760000
STATE    DS    AL1                 STATE OF DEVICE OR TERMINAL          09490000
PTUNAD   DS    HL1               MPX DEVICE ADDRESS OF TERMINAL         10220000
PUSENS   DS    HL1                 SENSE BYTE STORAGE                   10950000
SAVCSW   DS    FL8                 LAST NON-SENSE TERMINATION CSW       11680000
SAVSTAT  EQU   *                                                        12410000
PUCCB    DS    A                 ADDRESS OF MOST RECENT CCB SETTING     13140000
PUTERM   EQU   *                   PUB ONLY                             13870000
*              PUTERM IS PUB TO PERTERM LINK FOR WAIT                   14600000
*        PTR POINTS TO EITHER A PERTERM OR A PUBENT BLOCK               15330000
PUBENTL EQU *+4-PERTERM            PRECEDING BYTES ARE COMMON TO        16060000
*        TERMINALS AND OTHER MPX DEVICES                                16790000
*                                                                       17520000
*        FOLLOWING BYTES ARE FOR TERMINALS ONLY                         18250000
*                                  INITIAL VALUE IN CONFIGURATION       18980000
ACTIVE   DC    X'00'               INWAITM+NONINM                       19710000
MISCB    DC    X'00'               NOWSM                                20440000
IOB1     DC    X'00'               NSIGNM+DIVERT*?                      21170000
IOB2     DC    X'00'               Q4WMDM*?+LOEXP*?                     21900000
*        DUMMY PERTERMS HAVE WORD 0 = 0 AND NSIGNM & LVIDLEM            22630000
*        ACTIVE SETTINGS                                                23360000
ATTENM   EQU   X'80'               ATTENTION SIGNALLED BY TYPIST        24090000
OUTWAITM EQU   X'40'             OUTPUT BUFFER IS FULL                  24820000
INWAITM  EQU   X'20'             AWAITING INPUT FROM TYPIST             25550000
NONINM   EQU   X'10'               ZERO MEANS INPUT IS READY            26280000
LOCKM    EQU   X'02'               INVOLVED IN SAVE                     27010000
MISCM    EQU   X'01'             VARIOUS SUSPENSION CAUSES              27740000
*        MSICM IS    OR/ MISCB                                          28470000
ACTIVEM  EQU   INWAITM+OUTWAITM+MISCM  ALL ZERO MEANS READY TO RUN      29200000
*        MISCB SETTINGS                                                 29930000
NOWSM    EQU   X'01'              NO WORKSPACE ASSIGNED                 30660000
EXCPWM   EQU   X'02'               PSUEDO DOS WAIT,THIS DEVICE          31390000
WANTON   EQU   X'04'              TRYING TO SIGN ON                     32120000
SDWAIT   EQU   X'08'              WAITING TO DO SPECIAL DISK            32850000
REPWAITM EQU   X'10'               WAITING FOR REPLY                    33580000
TRAWAITM EQU   X'20'               MSGOUT SUSPENSION                    34310000
CLOKWAIT EQU   X'40'               WAIT FOR TIME INTERVAL               35040000
BUFFWAIT EQU   X'80'               WAIT FOR TYPEWRITER BUFFER           35770000
*        IOB1 SETTINGS                                                  36500000
TRREJ    EQU   X'02'              MSGOUT MACRO REJECTED                 37230000
COPYRM   EQU   X'04'               SINK DURING COPY OPERATION           37960000
COPYWM   EQU   X'08'               SOURCE FOR COPY OPERATION            38690000
BROADM   EQU   X'10'               BROADCAST MESSAGE AWAITING THIS TERM 39420000
RINGM    EQU   X'20'               ADDRESSED MESS AWAITING THIS TERM    40150000
NSIGNM   EQU   X'40'              NOT SIGNED ON                         40880000
PRIVBIT  EQU   X'80'               PRIVLEGED TERMINAL                   41610000
*        IOB2 SETTINGS                                                  42340000
Q4WMDM   EQU   X'80'               FOUR WIRE MODEM                      43070000
RECMM    EQU   X'40'               ACCEPT MESSAGES AT ANY TIME          43800000
LVIDLEM  EQU   X'10'               IGNORE TYO'S LINE IS DEAD            44530000
LOEXP    EQU   X'08'               LONG EXP IDENTIFIES EXPRESS LINE     45260000
SHEXP    EQU   X'04'               SHORT EXP EXPRESS MODE CONNECTION    45990000
BOUNCM   EQU   X'02'               FORCE SIGNOFF SOON                   46720000
         SPACE                                                          47450000
PTCORE   DS    A (PERCORE)         CORE AREA ASSOCIATED WITH TERMINAL   48180000
         DS    A,H                 RESERVED                             48910000
PTBFA    DS    H                   ALLOCATED BUFFER COUNT               49640000
PTFBUF   DS    A                   HEAD OF OUTPUT BUFF CHAIN            50370000
PTLBUF   DS    A                   TAIL OF I/O BUFFER CHAIN             51100000
PTIBUF   DS    A                   HEAD OF INPUT BUFFER CHAIN           51830000
PTRBUF   DS    A                   CHAIN TO RELEASE AT UNWZ             52560000
PTABTM   DS    1F                  ACTUAL BILLING TIME                  53290000
PTICTME  DS    1F                  COMPUTE TIME, THIS INTERVAL          54020000
*        PTICTM IS RESET BY  TYI                                        54750000
PTMTIME  DS    1F 'REALTIME'       PTMTIME IS USED FOR MEASURING        55480000
*        DURATIONS SUCH AS..       INWAIT = 1 (TYPING TIME)             56210000
*                                  INWAIT..=0 TO FIRE UP (RESPONSE)     56940000
*                                  NON-INPUT,NON-RESPONSE TIME          57670000
PTSOTM   DS    1F                  SIGN ON TIME                         58400000
PTMTIM2  DS    F                 FOR MEASURING TYI TO TYI TIME          59130000
PTMTIM3  DS    F                   CUMULATIVE KEYING TIME SINCE SIGNON  59860000
PTCPULIM DS    2H                  CPU TIME LIMIT                       60590000
PTCPULM2 EQU   PTCPULIM+2                                               61320000
DESBYTE  DS    1C                  TERM NUMBER OF MESSAGE ADDRESSEE     62050000
PTSAD    DS    1X                  SAD CCW                              62780000
PTCNT    DS    1X                  MINOR ERROR COUNT, THIS TERMINAL     63510000
PDSOP    DS    1X                  OPERATION                            64240000
PTRESP   DS    1C                  POLLING RESPONSE 1050 OR 2741        64970000
         DS    7X                  RESERVED                             65700000
*        TYPEWRITER CCW CHAIN                                           66430000
PTCCW1   DS    D                   POLLING CCW'S                        67160000
PTCCW2   DS    D                   READ RESPONSE                        67890000
PTCCW3   DS    A                   TIC TO FIRST BUFFER                  68620000
PTMAN    DS    F                   MAN NUMBER SIGNED ON THIS TERMINAL.  69350000
PTMANI   DS    3C                  FIRST THREE CHARACTERS OF HISNAME    70080000
PTDAYSON DS    C                   NUMBER OF MIDNIGHTS SINCE SIGN-ON.   70810000
*        PTWSQ, PTWSA ARE INITIALIZED AT SIGN-ON FROM MANTABLE          71540000
*        PTWSA IS INCREMENTED BY A SAVE OF NEW WORKSPACE, DECR BY DROP  72270000
*        PTWSQ IS CHANGED BY )ADD                                       73000000
PTWSQ    DS    H                   QUOTA FOR )SAVE                      73730000
PTWSA    DS    H                   ACTUAL NUMBER OF SAVED WORKSPACES    74460000
         DS    0D                                                       75190000
PERTERML EQU   *-PERTERM            LENGTH OF DSECT                     75920000
*                                                                       76650000
*                                                                       77380000
PDSDDDD  DSECT                     PARAMETER AREA FOR SPECIAL DISK      78110000
PDSLIB   DS    1F                  LIBRARY NUMBER                       78840000
PDSWSN   DS    CL12                WORKSPACE NAME                       79570000
         DS    1X                                                       80300000
PDSOPA   DS    1X                  OVERWRITABLE COPY OF SDOP IN TB      81030000
         DS    1X                                                       81760000
PDSTCNT  DS    1X                  TRACK COUNT FOR )SAVE                82490000
PDSPASS  DS    CL8                 PASSWORD                             83220000
PDSWSQI  DS    H                   INCREMENT FOR WORKSPACE QUOTA        83950000
PDSCPUL  DS    H                   CPU TIME LIMIT FOR )ADD              84680000
PDSID    DS    0CL78               ID FOR COPY                          85410000
PDSLEN   EQU   PDSID-PDSLIB        LENGTH FOR NON-COPY OP               86140000
*                                                                       86870000
*        TYPEWRITER BUFFER                                              87600000
*                                                                       88330000
PERBUF   DSECT                                                          89060000
PBCCW    DS    D                   CCW  ,PBSTAR, ,TBL-(PBSTAR-PERBUF)   89790000
PBFLAG   EQU   PBCCW+5             BUFFER STATUS FLAGS                  90520000
FORCELF  EQU   X'01'               PTCCW2 ONLY, SEE UNRZ26              91250000
FILLBIT  EQU   X'02'               TRANSLATED INPUT BUFFER FLAG         91980000
LINEZ    EQU   X'04'               END OF LINE                          92710000
LISTZ    EQU   X'08'               END OF LIST FOR FREEBUF              93440000
FREEBIT  EQU   X'10'               FREE BUFFER FLAG                     94170000
KILLFLAG EQU   FORCELF+FILLBIT     FORCE MXWCCC INTO MXDCCC             94900000
PBTIC    DS    F                   TIC TO NEXT BUFFER                   95630000
PBSTAR   DS    CL20                USEFUL PART OF BUFFER                96360000
PBLAST   EQU   *-1                 LAST CHAR OF BUFFER                  97090000
TBL      EQU   *-PERBUF                                                 97820000
*        END OF PERTERM COPY * * * * * * * * * * * * *                  98550000
./  ADD    NAME=PROLOG
         MACRO                                                          05260000
&N       PROLOG &F,&L                                                   10520000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  15780000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  21040000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       26300000
.********************************************************************** 31560000
.*       WARNING -- MKGARB BYPASSES THESE LINKAGE MACROS.  BE CAREFUL   36820000
.*       IF YOU CHANGE THE LINKAGES.                                    42080000
&N       STM   PR,LKR,0(TLR)                                            47340000
         BALR  PR,0                                                     52600000
         USING *,PR                                                     57860000
         LR    LR,TLR                                                   63120000
         AIF   (T'&F NE 'O').SL                                         68380000
         LA    TLR,16(0,TLR)                                            73640000
         MEXIT                                                          78900000
.SL      USING &F-16,LR                                                 84160000
         LA    TLR,(&L+7-&F)/8*8+16(0,TLR)                              89420000
         MEND                                                           94680000
./  ADD    NAME=QUEND
         MACRO                                                          12500000
&L       QUEND                                                          25000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  37500000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  50000000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       62500000
&L       EX    0,MQCELL                                                 75000000
         MEND                                                           87500000
./  ADD    NAME=REMCDC
         MACRO                                                          00230000
&REM     REMCDC                                                         00460000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972      00920000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971, 1972      01150000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01380000
*        START OF CDCOMP COPY                                           01610000
*        SUBROUTINE TO GENERATE DISC CCW CHAIN                          01840000
*        R1 = ADDRESS FOR READ OR WRITE CCW                             02070000
*        R2 = CAW   (PLACE TO STORE CCW)                                02300000
*        R3 = SEEK - SCHIDE WITH ADDRESS                                02530000
*        R6 = RETURN ADDRESS OF CDCOMP                                  02760000
*        LINK = RETURN ADDRESS OF CDCOMPS AND CDCOMPW                   02990000
         USING CDCPARS,4           DSECT WITH DISK PARAMETERS           03220000
         EXTRN CCWAR                                                    03450000
         EXTRN RD1DA                                                    03680000
&REM     MVC   CCPAR1+1(3),CDCAD+1 LOSE HIGH ORDER BYTE            DASD 03910000
*        INITIALIZE CCW GENERATION                                      04140000
         MVI   CCPASS,0          FIRST AREA MARK                        04370000
         OI    ARLIM+1,EMPTYM                                      5989 04600000
         OI    R4+1,EMPTYM                                         5989 04830000
         OI    R4+5,EMPTYM                                         5989 05060000
         OI    R5+1,EMPTYM                                         5989 05290000
         MVI   ONETRK,X'80'        SET 1-TRACK SWITCH OFF               05520000
         SPACE 2                                                        05750000
*        THE FOLLOWING ANALYSIS DISTINGUISHES FOUR CASES FOR CDCOMP.    05980000
*        IT COMPUTES ARLIM, THE ABSOLUTE ADDRESS OF THE END OF THE      06210000
*        FIRST DATA AREA, AND (IN R5) THE ABSOLUTE START ADDRESS OF THE 06440000
*        SECOND DATA AREA.  THE TABLE SHOWS THE FOUR CASES.             06670000
*                                                                       06900000
*        CASE    ARLIM   R5                CRITERIA                     07130000
*                                                                       07360000
*          1     MX      SVI              MX GEQ TLEN                   07590000
*          2     TLEN    SVI              TLEN LEQ SVI LSS WLEN+MX-TLEN 07820000
*          3     MX      WLEN+MX-TLEN     SVI GEQ WLEN+MX-TLEN          08050000
*          4     TLEN    TLEN             SVI LSS TLEN                  08280000
*                                                                       08510000
         SPACE 2                                                   5989 08740000
*  WHEN DATA-CHAINING CANNOT BE USED (CDCNDC = 1)                  5989 08970000
*  THEN THE FOLLOWING SPECIAL ACTIONS ARE TAKEN FOR CASE 1         5989 09200000
         SPACE 3                                                   5989 09430000
*  SWAP READ/WRITE                                                 5989 09660000
*        1A     TLEN    TLEN       SVI < TLEN + MX - TLEN|MX       5989 09890000
*                                       TREAT AS CASE 4 IFF        5989 10120000
*                                       MX AND SVI FALL INTO       5989 10350000
*                                       THE SAME TRACK MULTIPLE    5989 10580000
*        1B     MX      SVI                                        5989 10810000
*                             AS FOR CASE 2, LET CONTROL UNIT      5989 11040000
*                       WRITE ZEROS FROM  MX TO TLEN+MX-TLEN|MX    5989 11270000
*  LIB  READ/WRITE                                                 5989 11500000
*        IN ORDER TO KEEP THE APL LIBRAY DISKS PORTABLE BETWEEN    5989 11730000
*        SYSTEMS, THE DISK FORMAT WILL REMAIN UNCHANGED.  INSTEAD  5989 11960000
*        OF DATA-CHAINING FROM MX TO SVI, THE SMALLER OF THE TWO   5989 12190000
*        SECTIONS ( TRACK BOUNDARY TO MX OR SVI TO TRACK BOUNDARY) 5989 12420000
*        IS MOVED ADJACENT TO THE OTHER SO THE TRACK CAN BE        5989 12650000
*        WRITTEN AS ONE RECORD WITHOUT DATACHAINING                5989 12880000
*                                                                  5989 13110000
*       CASE   ARLIM              R5         CRITERIA              5989 13340000
         SPACE 2                                                   5989 13570000
*        1C     MX+TLEN-TLEN|MX   SVI+TLEN-TLEN|MX                 5989 13800000
*                                           TLEN < 2 TIMES TLEN|MX 5989 14030000
*                                                                  5989 14260000
*        1D     MX-TLEN|MX        SVI-TLEN|MX                      5989 14490000
*                                           TLEN > 2 TIMES TLEN|MX 5989 14720000
*                                                                  5989 14950000
         SPACE 6              END OF SPECIAL NOTES                 5989 15180000
         LM    1,3,CCPAR1                                               15410000
PHYMV    MVC   2(4,3),PHYCYL       MOVE CCHH INTO SEEK SCHIDE AREA DASD 15640000
         LM    4,5,MX-M(1)                                              15870000
         CR    4,5                                                      16100000
         BH    CCCX                MX GTR SVI, EVIL                     16330000
         A     4,=F'7'             ROUND MX TO DOUBLE-WORD BOUNDARY     16560000
         N     4,=F'-8'                                                 16790000
         LTR   2,4                                                      17020000
         BNH   CCCX                MX NEGATIVE                          17250000
         C     5,WLEN                                                   17480000
         BNL   CCCX                GEQ WSLENGTH, EVIL                   17710000
         N     5,=F'-8'            ROUND SVI DOWN TO DOUBLEWORD         17940000
         L     4,CDCBASE      CDCPARS ADDRESS                      5989 18170000
         L     0,TLENF                                             5989 18400000
         STH   0,TLENC+2                                           5989 18630000
         SPACE 2                                                   5989 18860000
*        MX AND SVI ARE VALID                                           19090000
         SPACE 2                                                   5989 19320000
*CURRENT REGS          SAME DATA AVAILABLE IN     NEEDED LATER     5989 19550000
*      0  TLEN                 TLENF OR TLENC+2    *               5989 19780000
*      1  M                    CCPAR1              *               5989 20010000
*      2  MX-M                                                     5989 20240000
*      3  SCHIDE ARG,          SCHCCW1             *               5989 20470000
*      4  CDCPARS              CDCBASE             *               5989 20700000
*      5  SVI-M                                    *               5989 20930000
         SPACE 3                                                   5989 21160000
         CR    2,5            MX=SVI, TREAT AS CASE 4              5989 21390000
         BNL   CCC8                WRITE ENTIRE WS, WITHOUT        5989 21620000
*                                     DATACHAINING FROM MX TO SVI  5989 21850000
         CR    5,0                                                      22080000
         BL    CCC8                SVI LSS TLEN, CASE 4                 22310000
         LA    3,0(1,2)       ABSOLUTE MX                          5989 22540000
         ST    3,ARLIM         IS DEFAULT END OF FIRST AREA        5989 22770000
         SR    2,0            REL MX-TLEN                          5989 23000000
         BP    CCC7X              MX > TLEN    CASE 1              5989 23230000
         A     2,WLEN              WLEN + MX - TLEN                     23460000
         CR    5,2                                                      23690000
         BL    CCC9                TLEN LEQ SVI LSS WLEN+MX-TLEN        23920000
*                                  , CASE 2                             24150000
         SPACE 3                                                   5989 24380000
*  CASE-3       ONE-TRACK WORKSPACE      SVI GEQ WLEN+MX-TLEN      5989 24610000
         SPACE 2                                                   5989 24840000
*              REG-2 CONTAINS START OF AREA 2 FOR DC WRITE         5989 25070000
         SPACE 3                                                   5989 25300000
         MVI   ONETRK,0            SET 1-TRACK FLAG ON                  25530000
         LR    3,5            SAVE SVI FOR LATER                   5989 25760000
         S     5,WLEN         -(WLEN-SVI)  LENGTH OF MOVE          5989 25990000
         STH   5,MVCLNGTH     SAVE LENGTH FOR MVC LOOP             5989 26220000
         MVC   COUNT,C256     EACH MVC WILL MOVE 256 BYTES         5989 26450000
         CLI   DOP+1,RDATA         IS THIS A READ?                 5989 26680000
         BNE   CCC11          WRITE A ONETRACK WS                  5989 26910000
*                                                                  5989 27140000
*  A READ OF A ONETRACK WORKSPACE.                                 5989 27370000
*        SAVE ADDRESSES FOR MVC AT RELOC                           5989 27600000
*        (WE NEVER DATACHAIN MX TO SVI FOR READ OF ONETRACK)       5989 27830000
*                                                                  5989 28060000
         L     5,WLEN         WORKSPACE LENGTH (END OF DATA)       5989 28290000
         LR    4,0                 TLEN                            5989 28520000
         AR    4,1                 ABSOLUTE END OF SINK            5989 28750000
         STM   4,5,R4         SAVE MVC ADDRESSES UNTIL RELOC       5989 28980000
         BR    6              SINCE THE WHOLE (ONETRACK)           5989 29210000
*              WORKSPACE HAS ALREADY BEEN READ, NO NEED TO         5989 29440000
*              BUILD ANY CCW'S HERE.                               5989 29670000
         SPACE 3                                                   5989 29900000
*        WRITE A ONE-TRACK WORKSPACE                               5989 30130000
CCC11    LR    5,2            START OF AREA TWO FOR DC WRITE       5989 30360000
         TM    CDCFLAGS,CDCNDC     MAY WE DATA CHAIN?              5989 30590000
         BZ    CCC7                BRANCH YES                      5989 30820000
         TS    CCPASS              ANOTHER PASS NOT NEEDED         5989 31050000
         LR    5,3            SVI                                  5989 31280000
         LR    4,0            TLEN                                 5989 31510000
         AR    4,1            M+TLEN                               5989 31740000
         B     CCC10A                                              5989 31970000
         SPACE 3                                                   5989 32200000
*  WE ARE PROCESSING A CASE 1 WORKSPACE                            5989 32430000
*                                                                  5989 32660000
CCC7X    TM    CDCFLAGS,CDCNDC  CAN WE DO IT THE EASY WAY BY       5989 32890000
         BZ    CCC7               DATA-CHAINING?     0=YES         5989 33120000
         AR    2,0            RELATIVE MX,  AGAIN                  5989 33350000
         SPACE 3                                                   5989 33580000
*   HANDLE   CASE 1    FOR  NO*DATA*CHAINING                       5989 33810000
         SPACE 3                                                   5989 34040000
         ST    5,R5           SAVE REG5                            5989 34270000
         LA    3,256          MAXIMUM LENGTH OF MVC                5989 34500000
C256     EQU   *-2  DC H'256' HALFWORD CONSTANT OF 256             5989 34730000
         SR    5,2            SVI - MX                             5989 34960000
         CR    5,3            256 > SVI-MX                         5989 35190000
         BL    *+6            * TO AVOID DESTROYING DATA IN MVC,   5989 35420000
         LR    5,3            * EACH MVC WILL MOVE ONLY            5989 35650000
         STH   5,COUNT        * 256 MIN SVI-MX    BYTES AT A TIME. 5989 35880000
         LR    5,2            MX                                   5989 36110000
         LR    3,4                 SAVE CDCPARS ADDRESS            5989 36340000
         DROP  4                                                   5989 36570000
         SR    4,4            ZERO FOR DIVIDE                      5989 36800000
         DR    4,0            REG4 IS  TLEN RES MX                 5989 37030000
*                             REG5 IS  MX DIV TLEN                 5989 37260000
         TM    CDCFLAGS-CDCPARS(3),CDCSWAP IS IT A SWAP OPERATION? 5989 37490000
         BZ    CCC10B         A LIB OPERATION - SET UP FOR MVC     5989 37720000
*                                                                  5989 37950000
*  I/O ON THE SWAP FILE - NO INCORE MOVE NEEDED                    5989 38180000
*        WRITE FULL WS (CASE4) IF MX AND SVI FALL INTO SAME TRACK  5989 38410000
*        OTHERWISE TREAT AS MODIFED CASE 2                         5989 38640000
*                                                                  5989 38870000
         SR    2,4            MX-TLEN|MX                           5989 39100000
         AR    2,0            TLEN+MX-TLEN|MX                      5989 39330000
         C     2,R5           SVI<TLEN+MX-TLEN|MX                  5989 39560000
         BNL   CCC8     WRITE ENTIRE WS, MX AND SVI IN SAME TRACK  5989 39790000
NOMOVE   L     5,R5           RESTORE REGS                         5989 40020000
         B     CCC7           TREAT AS (MODIFIED) CASE2            5989 40250000
         SPACE 3                                                   5989 40480000
*--------      SET UP TO DO THE INCORE MOVE FOR  CASE-1     ------ 5989 40710000
*                                                                  5989 40940000
*                                                                  5989 41170000
*   TO MINIMIZE CPU USAGE IN THE INCORE MOVE, THE SMALLEST MOVE    5989 41400000
*   POSSIBLE WILL BE MADE:                                         5989 41630000
*                                                                  5989 41860000
*      *  THE AREA FROM TRACK BOUNDARY TO MX        TLEN|MX        5989 42090000
*      *  THE AREA FROM SVI TO NEXT TRACK BOUNDARY  TLEN-TLEN|MX   5989 42320000
*      *  THE AREA FROM SVI TO END OF WORKSPACE     WLEN-SVI       5989 42550000
         SPACE 2                                                   5989 42780000
*   IN THE SETUP FOR THE MOVE ROUTINE, MVCLNGTH IS:                5989 43010000
*        POSITIVE IF THE AREA BELOW MX IS MOVED UP TO SVI.         5989 43240000
*        NEGATIVE IF SVI IS TO BE MOVED DOWN TO MX.                5989 43470000
         SPACE 2                                                   5989 43700000
CCC10B   SR    0,4            TLEN-TLEN|MX                         5989 43930000
         SPACE 1                                                   5989 44160000
*   REG.4 CONTAINS THE LENGTH OF THE PARTIAL TRACK BELOW MX        5989 44390000
*   REG.0 CONTAINS THE LENGTH OF THE PARTIAL TRACK ABOVE SVI       5989 44620000
         SPACE 1                                                   5989 44850000
         L     5,WLEN                                              5989 45080000
         S     5,R5           WLEN-SVI                             5989 45310000
         SPACE 1                                                   5989 45540000
*   REG.5 CONTAINS THE LENGTH OF  SVI TO WLEN                      5989 45770000
         SPACE 1                                                   5989 46000000
         CR    0,5            * SELECT THE SMALLER OF              5989 46230000
         BH    *+6            *    SVI TO TRACK MULTIPLE           5989 46460000
         LR    5,0            *OR  SVI TO WLEN                     5989 46690000
*                                                                  5989 46920000
*  NOW, SELECT THE SHORTEST MOVE, THE SECTION BELOW MX, OR         5989 47150000
*        THE SECTION ABOVE SVI.                                    5989 47380000
*                                                                  5989 47610000
         CR    4,5                                                 5989 47840000
         BL    *+6                                                 5989 48070000
         LNR   4,5            NEGATIVE LENGTH FOR SVI PORTION      5989 48300000
         STH   4,MVCLNGTH     SAVE IT FOR LATER                    5989 48530000
         LCR   4,4            COMPLEMENT FOR BACKWARD ADD BELOW    5989 48760000
         L     5,R5           SVI                                  5989 48990000
         AR    5,4            TRUE START OF SECOND AREA            5989 49220000
         A     4,ARLIM        TRUE END OF FIRST AREA               5989 49450000
         STM   4,5,R4         CORRECTED END OF FIRST,START OF NEXT 5989 49680000
         ST    4,ARLIM        END OF FIRST CCW STREAM              5989 49910000
         MVI   ONETRK,INCORMV      INDICATE A RELOC MOVE NEEDED    5989 50140000
         CLI   DOP+1,RDATA    ARE WE DOING A WRITE                 5989 50370000
         BE    CCC7           BRANCH IF THIS IS A READ             5989 50600000
         ST    5,R5           FOR USE AT NOMOVE                    5989 50830000
         AH    5,MVCLNGTH                                          5989 51060000
CCC10A   CLI   CDOP,8         CHECK FOR WRITE OF ALT DIRECTORY     5989 51290000
         BE    MVCEXIT        IF ALT DONT DO INCORE MOVE AGAIN     5989 51520000
         AH    4,MVCLNGTH                                          5989 51750000
*                                                                  5989 51980000
*  PREPARE TO DO INCORE MOVE BEFORE WRITE                          5989 52210000
*                                                                  5989 52440000
         LA    0,MVCEXIT      FAKE A RETURN ADDRESS                5989 52670000
         TM    MVCLNGTH,X'80' IS MVCLNGTH NEGATIVE ?               5989 52900000
         BO    MVCDOWN        IF SO, MOVE TO LOWER ADDRESSES       5989 53130000
*                                                                  5989 53360000
* MVCLOOP FOR: WRITE - MOVING MX PART UP AGAINST SVI               5989 53590000
*              READ  - MOVING SVI PART BACK UP WHERE IT BELONGS    5989 53820000
*                                                                  5989 54050000
MVCUP    LH    3,COUNT        GET   INCR                           5989 54280000
         LCR   2,3            THIS LOOP NEEDS NEGATIVE INCREMENT   5989 54510000
         BCTR  3,0            MVC NEED A SHORT COUNT               5989 54740000
         STC   3,MVCUPX+1     $$$ MODIFY MVC INSTRUCTION    $$$$$  5989 54970000
         AR    5,1            MAKE SINK ABSOLUTE                   5989 55200000
         AR    5,2            DECREMENT BY LENGTH OF FIRST MOVE    5989 55430000
         AR    4,2              DITTO                              5989 55660000
         LH    3,MVCLNGTH     LIMIT CHECK IS SOURCE MINUS LENGTH   5989 55890000
         LNR   3,3     IS POSITIVE FOR WRITES, NEG. FOR READ       5989 56120000
         AR    3,4                                                 5989 56350000
MVCUPX   MVC   0(*-*,5),0(4)                                       5989 56580000
         AR    5,2                                                 5989 56810000
         BXH   4,2,MVCUPX                                          5989 57040000
         LR    2,0            RETURN ADDRESS IS IN REG 0           5989 57270000
         BR    2              DO CLEANUP                           5989 57500000
*                                                                  5989 57730000
*        CALLED BY BAL  0,MVCREV                                   5989 57960000
*                                                                  5989 58190000
*        MOVE DATA BACK TO WHERE IT BELONGS IN CORE                5989 58420000
*                                                                  5989 58650000
MVCREV   LM    4,5,R4         GET SOURCE-SINK OR SINK-SOURCE       5989 58880000
         TM    MVCLNGTH,X'80' IS MVCLNGTH NEGATIVE ?               5989 59110000
         BO    MVCUP          IF SO, MOVE TO HIGHER ADDRESS        5989 59340000
*                                                                  5989 59570000
*  MVCLOOP FOR : WRITE - MOVING SVI DOWN TO MX                     5989 59800000
*                READ  - MOVING MX BACK DOWN WHERE IT BELONGS      5989 60030000
*                                                                  5989 60260000
MVCDOWN  LA    2,256          INCREMENT FOR BXLE                   5989 60490000
         LH    3,MVCLNGTH     NUMBER OF BYTES TO BE MOVED          5989 60720000
         LPR   3,3            MAKE SURE ITS POSITIVE               5989 60950000
         AR    3,4            SINK+LENGTH IS LIMIT ADDRESS         5989 61180000
         AR    5,1                 ABSOLUTE SOURCE FOR MOVE        5989 61410000
         SR    3,2            DECREMENT TO HANDLE SHORT LAST MOVE  5989 61640000
         BM    MVCDOWNS       DONT MOVE 256 IF ITS DESTRUCTIVE     5989 61870000
         SPACE 2                                                   5989 62100000
MVCDOWNX MVC   0(256,4),0(5)  MOVE 256 AT A TIME                   5989 62330000
         AR    5,2                                                 5989 62560000
         BXLE  4,2,MVCDOWNX   DO IT AGAIN                          5989 62790000
MVCDOWNS AR    3,2            ADJUST BACK TO REAL LIMIT            5989 63020000
         SR    3,4            LIMIT - BEGINNING ADR OF THIS MOVE   5989 63250000
         BZ    MVCDOWNZ       NO LAST MOVE REQUIRED                5989 63480000
         BCTR  3,0            MVC NEEDS SHORT COUNT                5989 63710000
         EX    3,MVCDOWNY     ONE MORE TIME                        5989 63940000
MVCDOWNZ LR    2,0            RETURN ADDRESS IS IN REG 0           5989 64170000
         BR    2              DO CLEANUP                           5989 64400000
MVCDOWNY MVC   0(*-*,4),0(5)  TARGET OF EXECUTE                    5989 64630000
         SPACE 3                                                   5989 64860000
MVCEXIT  LH    0,TLENC+2                                           5989 65090000
         CLI   ONETRK,0       WAS THIS THE ONE TRACK CASE ?        5989 65320000
         BNE   NOMOVE         IF NOT, RE-ESTABLISH REG.5           5989 65550000
         SPACE 2                                                   5989 65780000
CCC8     LR    5,0                 TLEN                                 66010000
CCC9     AR    0,1                 M + TLEN                             66240000
         ST    0,ARLIM                                                  66470000
CCC7     MVI   SELFERR,0           INDICATE MX AND SVI ARE VALID        66700000
         AR    5,1                 M + START ADDR, AREA 2               66930000
         LM    2,3,CCWAD                                           5989 67160000
         L     4,CDCBASE           CDCPARS ADDRESS                 5989 67390000
         USING CDCPARS,4                                           5989 67620000
*              CHAIN FOR EACH TRACK IS                                  67850000
*        CCW   SEEK,DADDR,CC,6                                          68080000
*        CCW   SCHIDEQ,DADDR+2,CC,K                                     68310000
*        TIC   *-8                                                      68540000
*        DATA MOVING CCW  (SEE BELOW)                                   68770000
*                                                                       69000000
*        DATA MOVING CCW IS EITHER READ DATA OR WRITE DATA.  IT WILL    69230000
* SOMETIMES USE DATA CHAINING TO OPERATE WITH NON-CONTIGUOUS AREAS OF   69460000
* CORE.  THE TWO AREAS OF A WORKSPACE ARE THE BYTES FROM  M  TO  MX     69690000
* AND THE BYTES FROM SVI TO END OF WORKSPACE.  FOR MULTIPLE-TRACK WORK- 69920000
* SPACES, THE LAST TRACK IS FILLED OUT WITH GARBAGE AS NECESSARY.       70150000
* FOR 1-TRACK WORKSPACES, GARBAGE PRECEDES SECOND AREA TO FILL OUT      70380000
* THE TRACK.  AFTER 1-TRACK WORKSPACE IS READ IN, SVI AND UP MUST BE    70610000
* RELOCATED.  DATA CHAINING IS TOO MARGINAL TO BE USED ON TRACK 1.      70840000
*                                                                       71070000
*                                                                       71300000
*        IN THE FOLLOWING,                                              71530000
*              R1 = ABSOLUTE ADDRESS FOR NEXT DATA TRANSFER             71760000
*              R2 = WORKING ADDRESS FOR THIS TRACK'S CCWS          DASD 71990000
*              R3 = ADDRESS OF SEEK, SEARCH INFORMATION  BBCCHHR        72220000
*              R4 = BASE ADDRESS OF CDCPARS                             72450000
*              R5 = ABSOLUTE STARTING ADDRESS OF SECOND AREA (GENERALLY 72680000
*                   SVI + M)                                            72910000
*                                                                       73140000
CCC2     ST    3,0(2)            FIRST WORD OF SEEK                     73370000
         MVC   4(4,2),=X'40000006'      SECOND WORD OF SEEK             73600000
         TS    CCFIRST             IS THIS THE FIRST WRITE PASS    DASD 74060000
         BNZ   CCC5                NO                              DASD 74290000
         TM    CDCFLAGS,RPS        WAS RPS SELECTED                DASD 74520000
         BZ    CCC5                NO                              DASD 74750000
         MVC   9(7,2),RPSCCW+1     MOVE IN MOST OF CCW             DASD 74980000
         MVI   8(2),SETSECTR       MOVE IN THE COMMAND             DASD 75210000
         LA    2,8(2)              BUMP PAST THIS CCW              DASD 75440000
CCC5     EQU   *                                                   DASD 75670000
.NORPS1  ANOP                      SIGH...                         DASD 75900000
         A     3,CCSKD           CHANGE SEEK TO SCHIDE                  76130000
         ST    3,8(2)            FIRST WORD OF SCHIDE                   76360000
         LA    0,8(2)            ADDRESS FOR TIC                        76590000
         ST    0,16(2)           TIC BACK TO SCHIDE                     76820000
         MVC   12(5,2),=X'4000000508'   SECOND WORD OF SCHIDE AND TIC   77050000
*        SETUP CCHH FOR NEXT TRACK                                      77280000
         ST    1,24(2)             DATA TRANSFER CCW                    77510000
         LA    1,1                                                 DASD 77740000
         A     1,0(3)              INCREMENT HEAD                  DASD 77970000
         EX    1,CC10              CLI  HMAX+1,0                        78200000
         BH    *+8                                                      78430000
         A     1,CCADJ             INCR CYL, RESET HEAD                 78660000
         ST    1,8(3)              CCHH NEXT TRACK                      78890000
         S     3,CCSKD           CHANGE BACK TO SEEK                    79120000
         L     1,24(2)             RESTORE R1                           79350000
*        FOLLOWING INSTRUCTION IS SET BY INITIALIZATION OF THIS LOOP    79580000
         MVC   24(1,2),DOP+1       MOVE IN OP CODE (READ OR WRITE) DASD 79810000
         MVC   28(4,2),TLENC     2ND WORD OF WD OR RD                   80040000
         A     1,TLENF             TRACK LENGTH                         80270000
         C     1,ARLIM                                                  80500000
         BL    CCC1                                                     80730000
*        END OF AN AREA                                                 80960000
         BE    CCC3              AREA FILLS LAST TRACK                  81190000
*                                                                       81420000
*              DATA CHAIN BETWEEN END AREA 1 AND START AREA 2           81650000
CCC6     L     0,ARLIM                                                  81880000
         S     0,24(2)                                                  82110000
         LH    1,28+2(2)                                                82340000
         ST    0,28(2)           COUNT FOR FIRST CCW                    82570000
         MVI   28(2),SLI                                           5989 82800000
         TM    CDCFLAGS,CDCNDC     MAY WE DATA CHAIN TO SVI?       5989 83030000
         BO    CCC3                NO                              5989 83260000
         MVI   28(2),DC                                                 83490000
         SR    1,0               BYTES REMAINING IN TRACK               83720000
         LA    1,0(1)              DESTROY HIGH ORDER GARBAGE           83950000
         ST    1,36(2)           DC CCW WORD COUNT                      84180000
         ST    5,32(2)             DC CCW ADDRESS                       84410000
         AR    1,5                 NEXT CCW ADDRESS                     84640000
         LA    2,8(2)            SPACE FOR DC WORD                      84870000
         TS    CCPASS              IS THIS END OF SECOND AREA           85100000
         BC    7,CCEND           YES                                    85330000
CCC4     OI    28(2),CC            COMMAND CHAIN FLAG              5989 85560000
         L     0,WLEN                                                   85790000
         A     0,CCPAR1            M                                    86020000
         ST    0,ARLIM             SETUP NEW AREA LIMIT                 86250000
         CR    1,0                 CHECK FOR CCW COUNT GTR WLEN-SVI     86480000
         BL    CCC1                NORMAL CASE                          86710000
         BH    CCC6                                                     86940000
CCC3     LR    1,5                 START ADDR, NEXT DATA TRANSFER       87170000
         TS    CCPASS              IS THIS END OF SECOND AREA           87400000
         BC    8,CCC4              NO                                   87630000
         NI    28(2),SLI           CCW FLAGS                       5989 87860000
         B     CCENDX              EXACTLY FILLS LAST TRACK             88090000
*        ALL FOUR CCW'S FOR TRACK ARE DONE                              88320000
CCC1     LA    2,32(2)           ADVANCE CAW                            88550000
         AH    3,=H'8'             NEW SEEK ADDRESS                     88780000
         B     CCC2              DO NEXT TRACK                          89010000
CCEND    MVI   28(2),X'10'       NO CHAINING, BUT SKIP DATA             89240000
         MVC   25(3,2),CCPAR1+1    SKIP CCW ADDR                        89470000
CCENDX   LA    2,32(2)                                                  89700000
         ST    2,EXPCSW            FOR USE AT SELNOR                    89930000
         SR    0,0                 EXPECT RESIDUAL COUNT OF 0           90160000
         STH   0,EXPCSW+6                                               90390000
         L     0,CCWAD            SELSTAR PARAMETER                     90620000
         BR    6                   RETURN                               90850000
         DROP  4                                                        91080000
*        MX OR SVI INVALID, MAY BE DISK READ TROUBLE                    91310000
         AIF   ('&SYSECT' EQ 'DISKSECT').DISK                      DASD 91540000
CCCX     CLI   DOP+1,X'06'                                              91770000
         BNE   CCCY                WRITE COMMAND                        92000000
         MVI   SELFERR,1           FORCE ERROR                          92230000
         BR    6                                                        92460000
CCCY     LA    4,FREE-M            ABANDON THIS WORKSPACE               92690000
         LR    5,4                 WRITE THE WORKSPACE BACK TO SWAP DSK 92920000
         STM   4,5,MX-M(1)                                              93150000
         LA    4,CCCZ                                                   93380000
         ST    4,FRSAVE-M+36(1)    WE NOW HAVE LEGAL MX, SVI AND SAVED  93610000
         BR    7              REENTER REMCDC                       DASD 93840000
*                                  PSW POINTING TO A 'LOAD EMPTY' SVC.  94070000
CCCZ     LEMP                                                           94300000
         AGO   .SUP                                                DASD 94530000
.DISK    ANOP                                                      DASD 94760000
CCCX     MVI   REJECT-M(1),1                                       DASD 94990000
         BR    6                                                   DASD 95220000
.SUP     ANOP                                                      DASD 95450000
         MEND                                                           95680000
./  ADD    NAME=SDREQ
         MACRO                                                          11110000
&L       SDREQ &BUF                                                     22220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  33330000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  44440000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       55550000
&L       LA    0,&BUF                                                   66660000
         SVCC  YYSDR               SPECIAL DISK REQUEST                 77770000
         MEND                                                           88880000
./  ADD    NAME=SIGNAL
         MACRO                                                          10000000
&L       SIGNAL &COND                                                   20000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  30000000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  40000000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       50000000
&L       LA    0,ON&COND                                                60000000
         L     1,=V(SIGNAL)                                             70000000
         BALR  1,1                                                      80000000
         MEND                                                           90000000
./  ADD    NAME=SVCC
         MACRO                                                          05550000
&N       SVCC  &CODE                                                    11100000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  16650000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  22200000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       27750000
         LCLC  &X,&C                                                    33300000
&X       SETC  '&CODE'                                                  38850000
&C       SETC  '0'                                                      44400000
         AIF   ('&CODE'(1,2) NE 'YY').S2                                49950000
&C       SETC  '&CODE'                                                  55500000
&X       SETC  'MAP'                                                    61050000
.S2      ANOP                                                           66600000
&N       DC    0H'0',AL4(APL&X-APLSVC+X'0A00'*X'10000')                 72150000
         ORG   *-2                                                      77700000
         AIF   ('&X' NE 'MAP').YCON                                     83250000
         DC    Y(&C)                                                    88800000
.YCON    MEND                                                           94350000
./  ADD    NAME=SVRAPE
         MACRO                                                          12500000
&L       SVRAPE                                                         25000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  37500000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  50000000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       62500000
&L       SVCC  YYRAPE                                                   75000000
         MEND                                                           87500000
./  ADD    NAME=TCOM
         MACRO                                                          01610000
&L       TCOM  &TYPE,&ADDR                                              03220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  04830000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  06440000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       08050000
         LCLC  &CODE                                                    09660000
.*       TERMINAL COMMUNICATION MACRO                                   11270000
.*       FIRST PARAMETER MAY BE ...                                     12880000
.*             SUSPEND             NO MESSAGE, JUST SUSPEND SENDER      14490000
.*             RECEIVE             ACCEPT MESSAGES FROM OTHER TERMINALS 16100000
.*             DELAY               DELAY FOR REQUESTED TIME INTERVAL    17710000
.*             MSG                 SEND MESSAGE TO TERMINAL R1          19320000
.*             PA                  SEND MESSAGE TO ALL TERMINALS        20930000
.*             HI                  SET MESSAGE FOR NEW SIGNONS          22540000
.*             LOG                 SEND MESSAGE TO LOG                  24150000
.*             BREL                RELEASE BUFFER CHAIN                 25760000
.*             SOOK                SIGN ON OK                           27370000
.*             OFFH                SIGN OFF BUT HOLD TELEPHONE LINE     28980000
.*             OFF                 SIGN OFF IMMEDIATELY                 30590000
.*                                                                      32200000
&L       DC    0H'0'                                                    33810000
         AIF   ('&TYPE' EQ 'RECEIVE').TC5                               35420000
&CODE    SETC  '&TYPE'                                                  37030000
         AIF   ('&TYPE' EQ 'LOG' OR '&TYPE' EQ 'HI').TC11               38640000
         AIF   ('&TYPE' EQ 'BREL' OR '&TYPE' EQ 'SOOK').TC9             40250000
         AIF   ('&TYPE' EQ 'OFF' OR '&TYPE' EQ 'OFFH').TC2              41860000
&CODE    SETC  'TRAN'                                                   43470000
         AIF   ('&TYPE' EQ 'MSG').TC11                                  45080000
         AIF   ('&TYPE' EQ 'SUSPEND').TC1                               46690000
&CODE    SETC  'BROAD'                                                  48300000
         AIF   ('&TYPE' EQ 'PA').TC11                                   49910000
&CODE    SETC  'DEL'                                                    51520000
         AIF   ('&TYPE' EQ 'DELAY').TC6                                 53130000
         MNOTE 'INCORRECT COMMUNICATION TYPE FOR TCOM'                  54740000
         MEXIT                                                          56350000
.TC5     NOP   0                   8 BYTE EXPANSION FOR OUTWAITM   3039 59570000
*        SVCC  YYREC                                                    61180000
         SVCC  YYREC                                               3039 62790000
         MEXIT                                                          64400000
.TC6     AIF   ('&ADDR' EQ '(0)').TC9                                   67620000
         AIF   ('&ADDR'(1,1) EQ '(').TC8                                69230000
         AIF   (T'&ADDR NE 'N').TC7                                     70840000
         AIF   (&ADDR LT X'1000').TC10  FITS IN A LA                    72450000
.TC7     L     0,=A(&ADDR)                                              74060000
         AGO   .TC9                                                     75670000
.TC11    AIF   ('&ADDR' EQ '(0)').TC9                                   77280000
         AIF   ('&ADDR'(1,1) EQ '(').TC8                                78890000
.TC10    LA    0,&ADDR                                                  80500000
.TC9     SVCC  YY&CODE                                                  82110000
         MEXIT                                                          83720000
.TC8     LR    0,&ADDR(1)                                               85330000
         AGO   .TC9                                                     86940000
.TC1     LA    0,0                 THIS IS GLITCH TO SUSPEND            88550000
         SVCC  YY&CODE                                             C049 90160000
         MEXIT                                                     C049 91770000
.TC2     NOP   0                                                        94990000
         SVCC  YY&CODE                                             C049 96600000
         MEND                                                           98210000
./  ADD    NAME=TQE
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  06660000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       13320000
TQE      DSECT                                                          19980000
TQEFLGS  DS    0C                                                       26640000
TQETCB   DS    A                                                        33300000
TQEFLNK  DS    A                   FORWARD LINK.                        39960000
TQEBLNK  DS    A                   BACKWARD.                            46620000
TQEVAL   DS    F                   INITIALLY, INTERVAL IN OS TU.        53280000
TQELHPSW DS    F                   LEFT HALF OF TCER PSW.               59940000
TQESAV   DS    F                   STIMER WORK AREA.                    66600000
TQESAADR DS    A                   R13 CONTENTS ON ENTRY TO TCER.       73260000
TQEEXIT  DS    A                   A(TCER)                              79920000
TQEGRS   DS    16F                 GRS FROM TCB DURING LIFE OF IRB.     86580000
TQEIQE   DS    2F                  IQE FOR IRB.                         93240000
./  ADD    NAME=TRCOMP
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02120000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  04240000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       06360000
TRCOMP   EQU   *                                                        08480000
*        COMPUTE TRACK COUNT FOR SAVE DIRECTORY SEARCH                  10600000
*        TRACK COUNT IS                                                 12720000
*        CEIL(MAX/TLEN,(TLEN LSS MX+WLEN-SVI)/WLEN MIN (MX MAX TLEN)    14840000
*              +WLEN-SVI) DIV TLEN                                      16960000
*        OR IN VAGUE ENGLISH,                                           19080000
*              IF M TO MX IS 1 TRACK OR MORE, TRACK COUNT IS TRACKS     21200000
*              NEEDED FOR M TO MX AND SVI TO WLEN.                      23320000
*              IF SVI IS LESS THAN TRACK LENGTH, TRACK COUNT IS TRACKS  25440000
*              NEEDED  TO WRITE OUT ENTIRE WORKSPACE.                   27560000
*              IF M TO MX AND SVI TO WLEN FIT ON ONE TRACK, TRACK COUNT 29680000
*              IS 1.                                                    31800000
*              IF MX IS LESS THAN TRACK LENGTH AND DATA WON'T FIT ON    33920000
*              ONE TRACK, TRACK COUNT IS AS IF MX EQUALLED TRACK LENGTH 36040000
*                                                                       38160000
*        SEE DISCUSSION OF CASES IN CDCOMP.                             40280000
*                                                                       42400000
         USING CDCPARS,4                                                44520000
*        ASSUME ALL LIBRARY DEVICES ARE OF THE SAME TYPE * * *          46640000
         LM    0,1,MX              MX, SVI                              48760000
         A     0,=F'7'             ROUND MX TO DOUBLE WORD BOUNDARY     50880000
         N     0,=F'-8'                                                 53000000
         N     1,=F'-8'            ROUND SVI DOWN                       55120000
         LR    5,0                                                      57240000
         L     2,TLENF                                                  59360000
         L     3,WLEN                                                   61480000
         SR    1,3                 SVI - WLEN                           63600000
         SR    0,1                 WLEN+MX-SVI                          65720000
         CR    0,2                 VS TLEN                              67840000
         BNH   TCOMP1              1-TRACK WORKSPACE                    69960000
         SR    2,5                 ROUNDED MX.                          72080000
         BNP   *+6                                                      74200000
         AR    0,2                 (WLEN-SVI) + MX MAX TLEN             76320000
         LR    1,0                                                      78440000
         CR    1,3                 MAYBE FULL WORKSPACE                 80560000
         LR    2,3                                                      82680000
         BL    *+6                 NO                                   84800000
TCOMP1   LR    1,2                                                      86920000
         A     1,TLENF             ROUND UP FOR DIVIDE                  89040000
         BCTR  1,0                                                      91160000
         SR    0,0                                                      93280000
         D     0,TLENF             TRACK COUNT IN R1                    95400000
*        END OF TRCOMP COPY * * * * * * *                               97520000
./  ADD    NAME=TYI
         MACRO                                                          12500000
&L       TYI                                                            25000000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  37500000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  50000000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       62500000
&L       SVCC  YYTYI                                                    75000000
         MEND                                                           87500000
./  ADD    NAME=TYO
         MACRO                                                          11110000
&L       TYO   &TEXT                                                    22220000
.*             5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  33330000
.*             5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  44440000
.*     REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       55550000
&L       LA    0,&TEXT                                                  66660000
         SVCC  YYTYO                                                    77770000
         MEND                                                           88880000
./  ADD    NAME=ZSYMBOLS
 TITLE 'Z S Y M B O L S -- G L O B A L   D E F I N A T I O N S'         00590000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01180000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01770000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       02360000
ZILG     EQU   0         DENOTES ILLEGAL CHARACTER                      02950000
ZEOS     EQU   1         END OF STATEMENT                               03540000
ZLEOS    EQU   2         END OF STATEMENT CONTAINING LABEL              04130000
ZDUM     EQU   3         DUMMY CHARACTER                                04720000
ZBFZ     EQU   4         END OF BUFFER MARKER                           05310000
ZFILL2   EQU   5                                                        05900000
ZFILL3   EQU   6                                                        06490000
ZFCOLON  EQU   7         FAKE COLON                                     07080000
ZFPER    EQU   8         FAKE PERIOD                                    07670000
ZECONST  EQU   9         FLOATING POINT CONSTANT (E-FORMAT)             08260000
ZBCONST  EQU   10        BIT CONSTANT                                   08850000
ZICONST  EQU   11        INTEGER CONSTANT                               09440000
ZFCONST  EQU   12        FLOATING POINT CONSTANT                        10030000
ZCCONST  EQU   13        CHARACTER CONSTANT                             10620000
ZLBR     EQU   14        LEFT BRACKET                                   11210000
ZRBR     EQU   15        RIGHT BRACKET                                  11800000
ZLPAR    EQU   16        LEFT PARENTHESIS                               12390000
ZRPAR    EQU   17        RIGHT PARENTHESIS                              12980000
ZSEMIC   EQU   18        SEMICOLON                                      13570000
ZSLASH   EQU   19        SLASH                                          14160000
ZBSLASH  EQU   20        BACK SLASH                                     14750000
ZLARROW  EQU   21        LEFT ARROW                                     15340000
ZRARROW  EQU   22        RIGHT ARROW                                    15930000
ZFE      EQU   23        FAKE E (FOR E-FORMAT NUMBERS)                  16520000
ZFOVB    EQU   24        FAKE OVERBAR (HIGH MINUS)                      17110000
ZDIER    EQU   25        DIERESIS (UPSHIFT 1)                           17700000
ZPLUS    EQU   26        PLUS                                           18290000
ZMINUS   EQU   27        MINUS                                          18880000
ZTIMES   EQU   28        TIMES                                          19470000
ZDIV     EQU   29        DIVIDE                                         20060000
ZSTAR    EQU   30        STAR                                           20650000
ZMAX     EQU   31        MAXIMUM                                        21240000
ZMIN     EQU   32        MINIMUM                                        21830000
ZMOD     EQU   33        RESIDUE                                        22420000
ZAND     EQU   34        AND                                            23010000
ZOR      EQU   35        OR                                             23600000
ZLT      EQU   36        LESS THAN                                      24190000
ZLE      EQU   37        LESS THAN OR EQUAL                             24780000
ZEQ      EQU   38        EQUAL                                          25370000
ZGE      EQU   39        GREATER THAN OR EQUAL                          25960000
ZGT      EQU   40        GREATER THAN                                   26550000
ZNE      EQU   41        NOT EQUAL                                      27140000
ZALPHA   EQU   42        ALPHA                                          27730000
ZEPS     EQU   43        EPSILON                                        28320000
ZIOTA    EQU   44        IOTA                                           28910000
ZRHO     EQU   45        RHO                                            29500000
ZOMEGA   EQU   46        OMEGA                                          30090000
ZCOMMA   EQU   47        COMMA                                          30680000
ZSHRIEK  EQU   48        SHRIEK (EXCLAMATION)                           31270000
ZREV     EQU   49        REVERSAL                                       31860000
ZBASE    EQU   50        CODE (BASE)                                    32450000
ZREP     EQU   51        DECODE (REPRESENTATION)                        33040000
ZCIRCLE  EQU   52        CIRCLE                                         33630000
ZQUERY   EQU   53        QUERY                                          34220000
ZNOT     EQU   54        NOT                                            34810000
ZUARROW  EQU   55        UP- ARROW                                      35400000
ZDARROW  EQU   56        DOWN ARROW                                     35990000
ZSUB     EQU   57        SUBSET                                         36580000
ZRSUB    EQU   58        RIGHT SUBSET                                   37170000
ZCAP     EQU   59        CAP                                            37760000
ZCUP     EQU   60        CUP                                            38350000
ZUND     EQU   61        UNDERSCORE                                     38940000
ZTRAN    EQU   62        TRANSPOSE                                      39530000
ZHIST    EQU   63        I-BEAM                                         40120000
ZNULL    EQU   64        NULL (SMALL CIRCLE)                            40710000
ZQUAD    EQU   65        QUAD                                           41300000
ZQUADP   EQU   66        QUAD-QUOTE                                     41890000
ZLOG     EQU   67        LOG                                            42480000
ZNAND    EQU   68        NAND                                           43070000
ZNOR     EQU   69        NOR                                            43660000
ZREM     EQU   70        LAMP-COMMENT                                   44250000
ZUPGRADE EQU   71        UPGRADE                                        44840000
ZDNGRADE EQU   72        DOWN GRADE                                     45430000
ZCOLREV  EQU   73        OVERSTRUCK CIRCLE-HYPHEN                       46020000
ZCOLSLSH EQU   74        OVERSTRUCK SLASH-HYPHEN                        46610000
ZCOLBSLH EQU   75        OVERSTRUCK BACKSLASH-HYPHEN                    47200000
ZDOMINO  EQU   76                                                       47790000
ZFILL17  EQU   77                                                       48380000
ZFILL18  EQU   78                                                       48970000
ZFILL19  EQU   79                                                       49560000
ZFILL20  EQU   80                                                       50150000
ZFILL21  EQU   81                                                       50740000
ZFILL22  EQU   82                                                       51330000
ZFILL23  EQU   83                                                       51920000
ZTDELTA  EQU   84        TRACE (T DELTA)                                52510000
ZSDELTA  EQU   85        PROGRAMMED STOP (S DELTA)                      53100000
ZA       EQU   86                                                       53690000
ZB       EQU   87                                                       54280000
ZC       EQU   88                                                       54870000
ZD       EQU   89                                                       55460000
ZE       EQU   90                                                       56050000
ZF       EQU   91                                                       56640000
ZG       EQU   92                                                       57230000
ZH       EQU   93                                                       57820000
ZI       EQU   94                                                       58410000
ZJ       EQU   95                                                       59000000
ZK       EQU   96                                                       59590000
ZL       EQU   97                                                       60180000
ZM       EQU   98                                                       60770000
ZN       EQU   99                                                       61360000
ZO       EQU   100                                                      61950000
ZP       EQU   101                                                      62540000
ZQ       EQU   102                                                      63130000
ZR       EQU   103                                                      63720000
ZS       EQU   104                                                      64310000
ZT       EQU   105                                                      64900000
ZU       EQU   106                                                      65490000
ZV       EQU   107                                                      66080000
ZW       EQU   108                                                      66670000
ZX       EQU   109                                                      67260000
ZY       EQU   110                                                      67850000
ZZ       EQU   111                                                      68440000
ZDELTA   EQU   112                                                      69030000
ZAU      EQU   113                                                      69620000
ZBU      EQU   114                                                      70210000
ZCU      EQU   115                                                      70800000
ZDU      EQU   116                                                      71390000
ZEU      EQU   117                                                      71980000
ZFU      EQU   118                                                      72570000
ZGU      EQU   119                                                      73160000
ZHU      EQU   120                                                      73750000
ZIU      EQU   121                                                      74340000
ZJU      EQU   122                                                      74930000
ZKU      EQU   123                                                      75520000
ZLU      EQU   124                                                      76110000
ZMU      EQU   125                                                      76700000
ZNU      EQU   126                                                      77290000
ZOU      EQU   127                                                      77880000
ZPU      EQU   128                                                      78470000
ZQU      EQU   129                                                      79060000
ZRU      EQU   130                                                      79650000
ZSU      EQU   131                                                      80240000
ZTU      EQU   132                                                      80830000
ZUU      EQU   133                                                      81420000
ZVU      EQU   134                                                      82010000
ZWU      EQU   135                                                      82600000
ZXU      EQU   136                                                      83190000
ZYU      EQU   137                                                      83780000
ZZU      EQU   138                                                      84370000
ZDELTAU  EQU   139                                                      84960000
Z0       EQU   140                                                      85550000
Z1       EQU   141                                                      86140000
Z2       EQU   142                                                      86730000
Z3       EQU   143                                                      87320000
Z4       EQU   144                                                      87910000
Z5       EQU   145                                                      88500000
Z6       EQU   146                                                      89090000
Z7       EQU   147                                                      89680000
Z8       EQU   148                                                      90270000
Z9       EQU   149                                                      90860000
ZPER     EQU   150       PERIOD                                         91450000
ZOVB     EQU   151       OVERBAR                                        92040000
ZBLANK   EQU   152       BLANK                                          92630000
ZQUOTE   EQU   153       QUOTE                                          93220000
ZCOLON   EQU   154       COLON                                          93810000
ZDEL     EQU   155       DEL (FN DEFN CHAR)                             94400000
ZCR      EQU   156       CARRIAGE RETURN                                94990000
ZEOB     EQU   157       END OF BLOCK                                   95580000
ZBS      EQU   158       BACKSPACE                                      96170000
ZLF      EQU   159       LINEFEED                                       96760000
ZPDEL    EQU   160       PROTECTION DEL                                 97350000
ZPFX     EQU   161       CIRCLE-D (PREFIX)                              97940000
ZBSUC    EQU   162       UPPER CASE BACKSPACE                           98530000
ZLENGTH  EQU   163       LENGTH OF ZSYMBOL TABLE                        99120000
./  ADD    NAME=APLSAGOR
AGOR     TITLE 'T H E   A G O R A N O M I C   R O U T I N E S 05/11/70' 00400000
*              5734-XM6 COPYRIGHT IBM CORP. 1969,1970,1972              00800000
*              5736-XM6 COPYRIGHT IBM CORP. 1969,1970,1972              01200000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01600000
         PRINT OFF       APLDEFN, PERTERM                               02400000
GETSPACE CSECT                                                          02800000
         PRINT NOGEN                                                    03200000
         COPY  APLDEFN                                                  03600000
         COPY  PERTERM                                                  04000000
         TITLE 'T H E   A G O R A N O M I C   R O U T I N E S 05/11/70' 04400000
         PRINT ON                                                       04800000
GETSPACE CSECT                                                          05200000
         EXTRN ERROR                                                    05600000
*              GETSPACE                                                 06000000
*              GET SPACE FOR AN ENTRY IN M.                             06400000
*CALLED WITH   R1 = BYTE COUNT                                          06800000
*              R2 = CREATE TEMP EST ENTRY ON STACK IF R2 = 0            07200000
*              RETURNS BASE ADDRESS OF ENTRY IN R1                      07600000
*              HEADER AND MX ARE ALWAYS ALIGNED ON WORD BOUNDARIES.     08000000
         PROLOG LOCALS,LE                                               08400000
         STM   0,7,GTVH-4          SAVE PARAMS AND CALLER'S REGS        08800000
GTV01    LA    4,3                 PICK UP NO. OF BYTES,                09200000
         A     4,GTVH              ROUNDED UP TO A WORD BOUNDARY.       09600000
         N     4,QFM4                                                   10000000
         L     1,MX                ADD THAT TO TOP OF CURRENTLY         10400000
         AR    4,1                 OCCUPIED SPACE                       10800000
         L     3,SVI               COMPARE NEW BASE OF FREE STORAGE     11200000
         LR    2,3                                                      11600000
         S     3,QF40              (PLUS A LITTLE SLOP)                 12000000
         CLR   4,3                 WITH TOP OF INVERTED STACK.          12400000
         BL    GTV02               DO WE HAVE ENOUGH SPACE --           12800000
         BAL   LKR,GCOL            NO.  DO A GARBAGE COLLECTION.        13200000
         B     GTV01               THEN RETRY.                          13600000
*                                                                       14000000
*              STORAGE RESERVATION PERFORMED SUCCESSFULLY               14400000
GTV02    L     0,GTVE              SHOULD WE CREATE A STACK ENTRY       14800000
         LTR   0,0                 TO GO WITH THIS M-ENTRY --           15200000
         BNE   GTV03               NO.                                  15600000
         LR    0,1                 COPY OLD MX TO R0                    16000000
         O     0,QTMPCLS           OR IN TEMP CLASS TO BUILD EST ENTRY  16400000
         ST    0,0(2,MR)           AND PUT IT ON TOP OF STACK.          16800000
         LA    3,36(3)             ***** NOTE DEPENDENCY ON S 3,QF40 ** 17200000
         ST    3,SVI               DROP STACK POINTER.                  17600000
         ST    2,MHEAD(1)          STORE STACK POINTER IN FIRST WORD OF 18400000
GTV03    ST    4,MX                M-ENTRY, THEN GIVE MX ITS NEW VALUE. 18800000
         SR    4,1                 FIND AGGREGATE BYTE COUNT OF M-ENTRY 19200000
         ST    4,MCOUNT(1)         AND STORE THIS IN COUNT WORD OF      19600000
*                                  M-ENTRY.                             20000000
         L     0,GTVH-4                                                 20400000
         LM    2,7,GTVH+4                                               20800000
         IRETURN                   ALL DONE.                            21200000
         EJECT                                                          21600000
         ENTRY MKGARB                                                   22000000
* ********************************************************************* 22400000
*        WARNING -- THIS PROGRAM BYPASSES THE LINKAGE MACRO.            22800000
*        LOOK CLOSELY IF YOU CHANGE THE LINKAGE.                        23200000
* ********************************************************************* 23600000
         USING MKLOCLS,14                                               24000000
*                                  EXCEPT FOR HIGH-ORDER 8 BITS OF R1,  24400000
MKGARB   LTR   1,1                 MKGARB SAVES ALL REGISTERS USED.     24800000
         BCR   4,15                IGNORE CALL IF POINTER IS INDIRECT.  25200000
         STM   15,3,MKGSR                                               25600000
         MVI   MKGHOL,0                                                 26000000
         BALR  15,0                                                     26400000
         USING *,15                                                     26800000
         N     1,QF24BITS                                               27200000
         BZ    MKG06               IGNORE CALL IF ADDRESS IS ZERO.      27600000
         LA    2,0(1,MR)                                                28000000
*        ON ENTRY, R1 IS POINTER TO M-ENTRY WHICH IS TO BE MARKED       28400000
*        GARBAGE.  IF M-ENTRY IS A LIST,  ALL SUBLISTS ARE MARKED TOO.  28800000
         TM    MGARB-M(2),MGBIT    FOR DEBUGGING, SEE IF THIS IS        29200000
         BZ    MKGT01              ALREADY GARBAGE.                     29600000
         LA    1,ESYSTEM           IF IT IS, DISASTER.                  30000000
         ICALL ERROR                                                    30400000
MKGT01   EQU   *                                                        30800000
         OI    MGARB-M(2),MGBIT    MARK THIS THING GARBAGE.             31200000
         C     1,MING              IF IT IS LOWER THAN MINIMUM GARBAGE  31600000
         BH    MKG03               UP TO NOW,                           32000000
         ST    1,MING              STORE ITS ADDRESS.                   32400000
*                                  MING GIVES GCOL A HEAD START.        32800000
MKG03    L     0,MINGL             ADD LENGTH OF THIS M-ENTRY           33200000
         A     0,MCOUNT(1)         TO MINGL.                            33600000
         ST    0,MINGL             SUPERVISOR MAY USE THIS TO DETERMINE 34000000
*                                  UTILITY OF A GARBAGE COLLECTION      34400000
*                                  BEFORE DISK SWAP.                    34800000
         TM    MLIST-M(2),MLSTBIT  IS THIS THING A LIST --              35200000
         BZ    MKG07               NO.  BYPASS SUBLIST MARKING.         35600000
         LH    2,MLSCT(1)          THIS IS A LIST.  GET COUNT OF        36000000
         SLL   2,2                 ELEMENTS, TIMES FOUR,                36400000
         AH    2,MLSOS(1)          PLUS OFFSET, TO DETERMINE ADDRESS OF 36800000
*                                  LAST SUBLIST ENTRY IN THIS LIST.     37200000
MKG04    CH    2,MLSOS(1)          HAVE WE LOOKED AT ALL SUBLISTS --    37600000
         BNH   MKG07               YES.  ADDRESS OF CURRENT SUBLIST     38000000
*                                  ENTRY EQUALS OFFSET (I.E. BELOW      38400000
*                                  FIRST SUBLIST ENTRY).                38800000
         S     2,QF4               NO.  DROP SUBLIST ENTRY ADDRESS.     39200000
         LA    3,0(2,1)            R3 IS M-RELATIVE SUBLIST ENTRY ADDR  39600000
         L     0,M(3)              PICK UP SUBLIST ENTRY.               40000000
         LTR   0,0                 IS IT AN M-POINTER --                40400000
         BNP   MKG04               NO.  EMPTY OR A SYMBOL TABLE POINTER 40800000
         ST    2,M(3)              YES.  SAVE SUBLIST ADDRESS IN JUST-  41200000
*                                  VACATED SUBLIST ENTRY POSITION.      41600000
*                                  WE FIND OUR WAY BACK FROM SUBLIST    42000000
*                                  BY USING SUBLIST'S M-HEADER WHICH    42400000
*                                  POINTS BACK TO THIS POSITION, WHICH  42800000
*                                  (IN A RELATIVE WAY) POINTS TO M-HEAD 43200000
*                                  OF THIS LIST.                        43600000
         LR    1,0                 R1 IS NOW M-POINTER OF SUBLIST.      44000000
         BR    15                  BACK TO TOP OF MKGARB FOR SUBLIST.   44400000
*              WE ENCOUNTERED A NON-LIST OR REACHED END OF A LIST       44800000
MKG07    C     1,MKGHOL            DOES CURRENT MPTR (R1) EQUAL MPTR WE 45200000
*                                  CAME IN WITH --                      45600000
         BE    MKG06               YES.  WRAP UP.                       46000000
         L     1,M(1)              NO.  THREAD OUR WAY BACK TO HIGHER   46400000
         N     1,QF24BITS                                               46800000
         L     2,M(1)              LEVEL LIST.                          47200000
         SR    1,2                 R2 IS OFFSET FROM MPTR.              47600000
         B     MKG04                                                    48000000
MKG06    LM    15,3,MKGSR          RELOAD ALL ALTERED REGISTERS         48400000
         BR    15                  AND RETURN.                          48800000
         EJECT                                                          49200000
*                                                                       49600000
*        GCOL  COMPACTS ENTRIES IN FREE-STORAGE AREA, DELETING ALL      50000000
*        ENTRIES WITH THE GARBAGE BIT ON AND RELOCATING ALL POINTERS    50400000
*        LEADING TO OR FROM A RELOCATED ENTRY, INCLUDING MULTIPLE       50800000
*        (LIST OR FUNCTION DIRECTORY) POINTERS.                         51200000
******** GCOL MUST NOT BE INTERRUPTED BY END QUANTUM.                   51600000
         ENTRY GCOL                                                     52000000
GCOL     PROLOG GCOLT,GCOLE                                             52400000
         STM   0,7,GCOLT                                                52800000
         L     6,MING              FIND LOWEST GARBAGE ENTRY            53200000
         LR    7,6                 THROUGHOUT,                          53600000
*                                  R4 = BYTE COUNT OF LIVE ENTRY        54000000
*                                  R6 = SOURCE ADDRESS OF LIVE ENTRIES  54400000
*                                  R7 = SINK ADDRESS                    54800000
*              REENTRY AFTER MOVING LIVE ENTRY OR DELETING GARBAGE      55200000
         SR    4,4                                                      55600000
         ST    4,MINGL             SET GARBAGE BYTE COUNT TO ZERO       56000000
         MVC   MING(4),MX          DOING THIS NOW HELPS TO PREVENT      56400000
*                                  ENDLESS LOOPS THROUGH PCSUB AND GCOL 56800000
GC01     AR    6,4                 ADJUST SOURCE BY GARBAGE BYTE COUNT  57200000
GC02     C     6,MING              HAVE WE REACHED END OF USED SPACE -- 57600000
         BNL   GC09                YES.                                 58000000
         L     3,MHEAD(6)          NO.  PICK UP HEADER WORDS.           58400000
         L     4,MCOUNT(6)                                              58800000
         LTR   3,3                 IS THIS ENTRY GARBAGE --             59600000
         BM    GC01                YES.  IGNORE GARBAGE BY SPACING PAST 60000000
         L     1,M(3)              NO. CHECK FOR VALID POINTER.         60800000
         LA    0,0(1)              POINTEE MUST POINT BACK TO US        61200000
         CR    0,6                                                      61600000
         BNE   QF4                 IF NOT EQ, FORCE PGM CHECK      2213 62000000
         AR    6,MR                FOR THE REMAINDER OF ANALYSIS OF     62400000
*                                  THIS M-ENTRY, R6 WILL BE ABSOLUTE.   62800000
         IC    0,M(3)              ADJUST THE POINTER OF ITEM WHICH     63200000
         ST    7,M(3)              REFERENCES THIS ENTRY                63600000
         STC   0,M(3)                                                   64000000
         TM    MLIST-M(6),MLSTBIT  IS THIS ENTRY A LIST --              64400000
         BZ    GC10                NO.  GO RELOCATE THIS ENTRY.         64800000
         LH    2,MLSOS-M(6)        YES.  LOAD OFFSET OF FIRST POINTER   65200000
         LH    5,MLSCT-M(6)        AND COUNT OF LIST POINTERS.          65600000
         LA    1,0(2,7)            R1 IS REL ADDR OF SINK LIST ENTRY    66000000
         AR    2,6                 MAKE R2 = RELATIVE ADDR              66400000
         SR    2,MR                OF LIST ENTRY                        66800000
         LTR   5,5                 LIST MAY BE EMPTY                    67200000
         BZ    GC10                IT IS. SKIP POINTER-ADJUSTMENT LOOP. 67600000
GC07     L     3,M(2)              FOR EACH POINTER IN THIS ENTRY,      68000000
         LTR   3,3                 IF THE POINTER IS NEITHER ZERO       68400000
         BNP   GC08                NOR NEGATIVE (FLAG TO INDICATE THAT  68800000
*                                  POINTED ITEM IS IN BST AND DOES NOT  69200000
*                                  POINT BACK TO US),                   69600000
         IC    0,M(3)                                                   70400000
         ST    1,M(3)                                                   70800000
         STC   0,M(3)                                                   71200000
GC08     LA    2,4(2)              GET ADDRESS OF NEXT POINTER          71600000
         LA    1,4(1)              IN SINK AREA ALSO                    72000000
         BCT   5,GC07              AND ADJUST ITS POINTEE.              72400000
*                                                                       72800000
*              ALL POINTERS TO THIS ENTRY HAVE BEEN ADJUSTED.           73200000
GC10     LA    0,256               THE REAL GARBAGE COLLECTION.         73600000
         LA    2,0(7,MR)           R2 IS ABSOLUTE SINK ADDRESS          74000000
         AR    7,4                 PREBUMP R7 TO END OF SINK AREA       74400000
         S     4,QF257             ADJUST BYTE COUNT FOR MVC            74800000
*                                  AND SHORT LAST MOVE.                 75200000
         BM    GC11                NEXT IS FOR ENTRIES GTR 256 BYTES    75600000
         LA    1,0(2,4)            R1 IS LIMIT FOR R2 IN BXLE           76000000
*                                  ( = LENGTH - 257 + SINK ADDRESS)     76400000
GC12     MVC   0(256,2),0(6)       MOVE 256 BYTES AT A TIME             76800000
         AR    6,0                 ADD 256 TO SOURCE ADDRESS            77200000
         BXLE  2,0,GC12            AND TO SINK, AND BRANCH FOR NEXT     77600000
*                                  LONG MOVE.                           78000000
GC11     EX    4,GCMVC             FINISH UP MOVE WITH A SHORT MVC.     78400000
         SR    6,2                 ADJUST SOURCE                        78800000
         AR    6,7                 TO RELATIVE ADDR OF NEXT ENTRY.      79200000
*              NOTES ON PREVIOUS TWO INSTRUCTIONS ..                    79600000
*              R2 = R7 + MR + FLOOR (R4-1) DIV 256                      80000000
*              R6' = R6 + FLOOR (R4-1) DIV 256                          80400000
*              R7' = R7 + R4                                            80800000
*        SO R6' + R7' - R2 = R6 + R4 - MR                               81200000
*                                                                       81600000
         B     GC02                                                     82000000
*              COLLECTION COMPLETED.  CHECK FOR M FULL AND SYSTEM ERROR 82400000
*                                  GIVE MX AND MING NEW VALUE OF TOP OF 82800000
*                                  COMPACTED SPACE.                     83200000
*                                  SYSTEM ERROR IF WE DIDN'T HIT MX     83600000
GC09     ST    7,MX                EXACTLY WITH OUR SOURCE INDEX.       84000000
         ST    7,MING                                                   84400000
         LA    1,ESYSTEM                                                84800000
         BNE   GC19                                                     85200000
         CR    6,7                 DID WE COLLECT ANY GARBAGE AT ALL -- 85600000
         BNE   GC18                YES. QUIT WITH SATISFACTION.         86000000
         LA    1,EMFULL            NO.  GCOL'S CALLER HAS RUN OUT OF    86400000
GC19     ICALL ERROR               SPACE.                               86800000
GC18     LM    0,7,GCOLT                                                87200000
         IRETURN                                                        87600000
*                                                                       88000000
GCMVC    MVC   0(0,2),0(6)         EXECUTED MVC                         88400000
QFM4     DC    F'-4'                                                    88800000
*        GCOL NEEDS X'00' IN HI ORDER BYTE OF FOLLOWING CONSTANT   2213 89200000
*        TO FORCE PGM CHECK -- EVEN ON MACHINES THAT DON'T         2213 89600000
*        REQUIRE BOUNDARY ALIGNMENT FOR CPU INSTRUCTIONS.          2213 90000000
QF4      DC    F'4'                                                     90400000
QF40     DC    F'40'                                                    90800000
QF257    DC    F'257'                                                   91200000
QF24BITS DC    X'00FFFFFF'                                              91600000
QTMPCLS  DC    AL1(CONST)                                               92000000
         DC    FL3'0'                                                   92400000
         LTORG                                                          92800000
LOCALS   DSECT                                                          93200000
         DS    F                                                        93600000
GTVH     DS    F                   BYTE COUNT FOR M-ENTRY               94000000
GTVE     DS    F                   SHOULD WE MAKE AN EST ENTRY          94400000
         DS    5F                                                       94800000
LE       EQU   *                                                        95200000
MKLOCLS  DSECT                                                          95600000
MKGSR    DS    2F                                                       96000000
MKGHOL   DS    F                   M-POINTER ON ENTRY TO MKGARB         96400000
         DS    2F                                                       96800000
GCOLT    DSECT                                                          97200000
         DS    8F                  REGISTER SAVE                        97600000
GCOLE    EQU   *                                                        98000000
         END                                                            98400000
./  ADD    NAME=APLSAPLM
APLM     TITLE 'APL MOTHER.'                                            00130000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00260000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00390000
APLOS    CSECT                                                          00780000
         COPY  APLDEFN                                                  00910000
         COPY  PERTERM                                                  01040000
         PRINT ON                                                       01170000
         TITLE 'A P L   M O T H E R  -  INITIATION OF APL.'             01300000
*                                                                       01430000
*                                                                       01560000
*        THIS ROUTINE ..                                                01690000
*                                                                       01820000
*        ATTACHES AND RUNS CONCURRENTLY WITH SUPINI ..                  01950000
*        BUT ..                                                         02080000
*        THE INITIATION IS COMPLETELY INTERLOCKED (USING WAIT AND POST) 02210000
*        AND EITHER THE MOTHER OR SUPINI IS WAITING ON THE OTHER AT ALL 02340000
*        TIMES UNTIL THE LAST POST BEFORE THE LABEL 'MOTHER'.           02470000
*                                                                       02600000
*                                                                       02730000
*        APL (OS) RUNS WITH TWO TCBS..                              MFT 02860000
*        TCBMERE - ALWAYS AT THE LIMIT PRIORITY.                        02990000
*        TCBFILLE - ALTERNATES BETWEEN THE LIMIT PRIORITY AND ZERO.     03120000
*        SEE CODE IN APLSUP AT APLSETHI, APLSETLO.                      03250000
*                                                                       03380000
*        APL360 TIMER CODE AND MULTIPLEX CODE MUST RUN ON THE           03510000
*        MOTHER TCB.                                                    03640000
*                                                                       03770000
APLOS    CSECT                                                      MFT 03900000
         USING *,15                                                C045 04030000
         B     APLOSAVE            SKIP AROUND DEBUGGING AIDS      C045 04160000
         DC    V(COIBM)       COPYRIGHT NOTICE                     C045 04290000
         DC    V(APLXREF)         THIS IS EASIER ON THE EYEBALLS   C045 04420000
         DROP  15                                                  C045 04550000
APLOSAVE STM   14,12,12(13)        CONVENTIONAL SAVE OF REGISTERS  C045 04680000
         BALR  12,0                ESTABLISH ADDRESSING.                04810000
         USING *,12                AND ALL THAT.                        04940000
*        ESTABLISH AN OS PROBLEM PROGRAM SAVE AREA.                     05070000
         LA    14,MVTSAVE          SAVE AREA LOCATION.                  05200000
         ST    14,8(13)              SAVE AREA FORWARD CHAIN        K10 05330000
         ST    13,OSR13-MVTSAVE(14)  SAVE AREA BACK CHAIN           K10 05460000
         LR    13,14                                                    05590000
         L     2,0(1)              // EXEC PARM LIST ADDRESS.      P062 05720000
         ST    2,PARAM+8           PASS PARM FIELD ADDRESS TO SINI.P062 05850000
         MVI   PARAM+8,X'00'       TURN OFF DEBUG FLAG.            P062 05980000
         CLC   =H'0',0(2)          ANY PARMS?                      P062 06110000
         BE    ATTACH              NO.                             P062 06240000
         MVI   PARAM+8,X'80'       TURN ON DEBUG FLAG.             P062 06370000
         LR    3,2                 SAVE FOR LATER.                 P062 06500000
         LA    4,11                OPERAND LENGTH.                 P062 06630000
         CLI   2(2),C'('           LIST?                           P062 06760000
         BNE   NOPAREN             NO                              P062 06890000
         LA    2,1(2)              SKIP OVER LEFT PAREN.           P062 07020000
NOPAREN  CLC   2(11,2),=C'DEBUG,SPLIT'                             P062 07150000
         BE    SPL                                                 P062 07280000
         CLC   2(11,2),=C'SPLIT,DEBUG'                             P062 07410000
         BE    SPL                                                 P062 07540000
         LA    4,5                 OPERAND LENGTH.                 P062 07670000
         CLC   2(5,2),=C'DEBUG'                                    P062 07800000
         BE    DEB                                                 P062 07930000
         MVI   PARAM+8,X'00'       TURN OFF DEBUG FLAG.            P062 08060000
         CLC   2(5,2),=C'SPLIT'                                    P062 08190000
         BE    SPL                                                 P062 08320000
INVPARM  WTO   'APL     INVALID OPERAND IN PARM FIELD OF EXEC CARD',   X08450000
               ROUTCDE=(1,11)                                      P062 08580000
         LA    15,24               RETURN CODE                     P062 08710000
         B     RETURN              RETURN TO OS.                   P062 08840000
DEB      MVI   ATTACHH1,0          TURN OFF H1 FLAG FOR ATTACH.    P062 08970000
SPL      SR    2,3                 0 OR 1 LEFT.                    P062 09100000
         AR    2,2                 0 OR 2                          P062 09230000
         LA    2,0(2,4)            MOVE PAST OPERANDS.             P062 09360000
         CH    2,0(3)              PROPER LENGTH?                  P062 09490000
         BNE   INVPARM             NO.                             P062 09620000
         CLI   PARAM+8,X'80'       DEBUG ON?                       P062 09750000
         BNE   ATTACH              NO.                             P062 09880000
* ENSURE THERE IS 10K FOR DEBUG                                    P062 10010000
         GETMAIN EC,LV=10240,A=GMFM                                P062 10140000
         LTR   15,15               CORE AVAILABLE?                 P062 10270000
         BZ    DEBF                YES - FREE IT.                  P062 10400000
         WTO   'APL     INSUFFICIENT CORE STORAGE',ROUTCDE=(1,11)  P062 10530000
         LA    15,4                RETURN CODE.                    P062 10660000
         B     RETURN              RETURN TO OS.                   P062 10790000
GMFM     DS    F                                                   P062 10920000
DEBF     FREEMAIN E,LV=10240,A=GMFM                                P062 11050000
ATTACH   ATTACH SF=(E,ATTACHL),MF=(E,PARAM)                        P062 11180000
         SPACE                                                          11310000
*        SAVE TCB ADDRESSES.                                            11440000
         ST    1,TCBFILLE          ADDRESS OF DAUGHTER TCB.             11570000
         L     1,CVT               CVT POINTER.                         11700000
         USING CVTD,1                                                   11830000
         L     1,CVTTCBP                                                11960000
         DROP  1                                                        12090000
         L     1,4(1)              CURRENT TCB ADDRESS.                 12220000
         ST    1,TCBMEREA          MOTHER TCB ADDRESS.                  12350000
*                                                                       12480000
*        THE FOLLOWING ENQ IS USED BY THE APL UTILITIES TO DETERMINE    12610000
*        IF APL IS RUNNING.                                             12740000
*        IF THE UTILITIES ARE RUNNING AT THIS TIME, APL SHOULD BE       12870000
*        BLOCKED UNTIL THEY TERMINATE.                                  13000000
*                                                                       13130000
         ENQ   (QNAME,RNAME,E,,SYSTEM)                                  13260000
*                                                                       13390000
*        WAIT UNTIL POSTED BY SUPINI AT COMPLETION OF INITIALIZATION.   13520000
*                                                                       13650000
         SPACE                                                          13780000
         WAIT  ECBLIST=ECBLIST                                      K06 13910000
*                                                                       14040000
*        WHEN DISPATCHED, SUPINI HAS EITHER COMPLETED INITIALIZATION,   14170000
*        OR HAS GIVEN UP.  RETURN CODE TELLS WHICH.                     14300000
*                                                                       14430000
         TM    ECBAPL,X'40'        SEE IF DAUGHTER TERMINATED.          14560000
         BO    DETACH1             GIVE UP IF SO.                       14690000
         L     1,PARAM+4  ATTACH PARAMETER LIST WAS CHANGED BY SINI K05 14820000
         MVC   ALIST(ALISTZ-ALIST),0(1) MOVE LIST TO MOTHER.            14950000
*                                                                       15080000
*        PASS ADDRESSES TO APLSUP.                                      15210000
*                                                                       15340000
*        SUPINI HAS PASSED..                                            15470000
*                                                                       15600000
*        A(ECBINIT)                SUPINI'S ECB.                        15730000
*        X'FLGS'              OSFLG FROM SINI                           15860000
*                                                                       15990000
*        THE FOLLOWING SEQUENCE IN APLSUP IS ASSUMED.                   16120000
*        TCBMERE                                                        16250000
*        TCBFILLE                                                       16380000
*        RBMERE                                                         16510000
*        RBFILLE                                                        16640000
*        ECBMERE                                                        16770000
*        ECBFILLE                                                       16900000
*        APLTCXRA                                                       17030000
*                                                                       17160000
         L     1,TCBMEREA          ADDRESS OF MOTHER TCB.               17290000
         MVC   SK(1),TCBPKE(1)     STORAGE KEY OF THIS REGION.          17420000
*                                                                       17550000
         L     1,TCBRBP(1)         POINTER TO PRB OF MOTHER             17680000
         ST    1,RBMERE            ADDRESS OF MOTHER PRB                17810000
*                                                                       17940000
*        KEEP DISPATCHING PRIORITY OF DAUGHTER SLIGHTLY LOWER THAN      18070000
*        MOTHER SO THAT MOTHER WILL ALWAYS BE RUN IN PREFERENCE.        18200000
*                                                                       18330000
         L     1,TCBFILLE          ADDRESS OF DAUGHTER TCB              18460000
*                                                                       18590000
         L     2,=A(CHAPLOW)       PRIORITY CHANGE VALUES IN APLSUP.    18720000
         SR    0,0                                                      18850000
         IC    0,TCBDSP(1)         DAUGHTER DISPATCHING PRIORITY        18980000
         SH    0,=H'12'            MAKE MINIMUM  DPRTY=(0,12)           19110000
         BNM   *+6                                                      19240000
         SR    0,0                 LEAVE ZERO IF TOO SMALL.             19370000
         STH   0,2(2)              PRIORITY INCREMENT.                  19500000
         LNR   0,0                                                      19630000
         STH   0,0(2)              PRIORITY DECREMENT.                  19760000
         L     1,TCBRBP(1)                                              19890000
         ST    1,RBFILLE           ADDRESS OF DAUGHTER PRB.             20020000
         L     1,APLSGENE          APLSUP GENEOLOGY.                    20150000
         MVC   0(GENEZ-TCBMEREA,1),TCBMEREA ALL ADDRESSES TO APLSUP.    20280000
         SPACE 3                                                        20410000
*        THE FOLLOWING INSTRUCTION SETS THE ABEND EXIT FOR MOTHER       20540000
*        TO 'STEP', A ROUTINE IN THIS ASSEMBLY.                         20670000
*        THE ABEND EXIT WILL NOT BE ENTERED ON AN OPERATOR CANCEL.      20800000
         STAE  STEP                                                C046 20930000
         LTR   15,15          JUST IN CASE                              21060000
         BNZ   STAERR         THATS ALL                                 21190000
         EJECT                                                      K10 21320000
*                                                                       21450000
*        ENTER SUPERVISOR STATE, DISABLED.                              21580000
*                                                                       21710000
         L     1,SVOLDPA           LOCN OF APLSUP SVC OLD.              21840000
         L     11,ACURRENT         XENOPHOBIC SVC ROUTINE.              21970000
         L     11,0(11)                                                 22100000
*                                                                       22230000
*        NOTE...                                                        22360000
*        ALL CODE BELOW THIS POINT MUST RUN IN SUPERVISOR STATE,        22490000
*        ZERO PROTECT KEY, AND DISABLED.                                22620000
*                                                                       22750000
         SVRAPE                                                         22880000
         MVC   0(2,1),=X'0004'     ONE INSTRUCTION WITH KEY OF ZERO.    23010000
*                                                                       23140000
*        SWAP IO NEW PSWS.                                              23270000
*                                                                       23400000
         MVC   OSIONEW(8),IONEWPSW SAVE CURRENT IO NEW PSW.             23530000
         L     1,APLIONEW          LOCATION OF APLSUP IO NEW PSW.       23660000
         MVC   IONEWPSW(8),0(1)    TO LOW CORE.                         23790000
         MVC   0(8,1),OSIONEW      OS IO NEW PSW TO APLSUP.             23920000
         EJECT                                                      K10 24050000
*                                                                       24180000
*        INITIAL TIMER EVENT.                                           24310000
*                                                                       24440000
         STIMER REAL,APLTCXR,TUINTVL=TWOSEC                             24570000
*        THE FOLLOWING CODE OBTAINS THE ADDRESS OF THE TQE              24700000
*        CREATED BY THE INITIAL STIMER, THEN INITIALIZES THE            24830000
*        VARIABLE TQEPSECT IN APLSUP. SETINT USES TQEPSECT TO           24960000
*        REFRESH THE TQE BEFORE CALLING THE TQE ENQUEUE ROUTINE.        25090000
         L     1,TCBMEREA          ADDRESS OF MOTHER TCB.               25220000
         L     1,120(1)            TCBTME IN MOTHER TCB.                25350000
         L     2,ATQEX             A(A(TQE)) IN APLSUP.                 25480000
         ST    1,0(2)                                                   25610000
         MVC   4(TQEGRS-TQEFLGS,2),0(1)   TQEPSECT IN APLSUP.           25740000
*              SET TQE FLAG BYTE.                                       25870000
         OI    4(2),X'80'     SET  OFF Q  FLAG                      MFT 26000000
*                                                                   MFT 26130000
*        SEVERAL INSTRUCTIONS AT EXIT  OF THE TIMER COMPLETION      MFT 26260000
*        EXIT ROUTINE ARE FOR MVT ONLY.                             MFT 26390000
*        THEY WILL NOW BE DELETED IF THIS IS MFT                    MFT 26520000
*                                                                   MFT 26650000
         TM    OSFLG,MFT      MFT?                                  MFT 26780000
         BZ    RELSINI        NO CHANGES IF MVT                     MFT 26910000
         MVC   TCXRX(TCXRZ-TCXRF),TCXRF                             MFT 27040000
         SPACE 3                                                    MFT 27170000
RELSINI  EQU   *                                                    MFT 27300000
*                                                                   MFT 27430000
*        RELEASE SUPINI .                                               27560000
*                                                                       27690000
         L     1,ECBINIT           SUPINI'S ECB.                        27820000
         POST  (1)                 POSTED.                              27950000
         TITLE 'SPECIAL EMERGENCY CANCEL COMMAND FOR APL/360-OS '  C046 28080000
*                                                                       28210000
*  THIS IS REQUIRED BECAUSE THE STAE EXIT DOES NOT RECEIVE CONTROL      28340000
*     FOR OPERATOR CANCEL.                                              28470000
*                                                                       28600000
*     N.B.   SAME IS TRUE FOR ANY X22 ABEND AND IF ANY OF THESE         28730000
*     OCCURS, IT WILL MEAN THAT APL HAS NOT BEEN GIVEN A CHANCE         28860000
*     TO RESTORE THE I/O NEW PSW.                                       28990000
*                                                                       29120000
*     A SYSTEM RE-IPL IS NECESSARY TO ENSURE PROPER OPERATION OF        29250000
*     OS/360                                                            29380000
*                                                                       29510000
*     BEWARE OF SEEMINGLY CORRECT OPERATION AFTER A X22 ABEND.          29640000
*     SUCH IS A FALSE CONDITION, AND SYSTEM WILL FAIL AS SOON           29770000
*     AS THE I/O INTERRUPT HANDLER THAT STILL REMAINS IN CORE (FROM     29900000
*     THE APL JOB) IS OVERLAID BY OTHER CODE OR DATA.                   30030000
*                                                                       30160000
*                                                                   K11 30290000
REQC     WTOR  'REPLY ''ABEND APL'' TO ABNORMALLY TERMINATE APL.',  K11C30420000
               REPLY,9,REPLYECB,ROUTCDE=(1,11)                      K11 30550000
         TITLE 'A P L   M O T H E R  -  CONCURRENT MOTHER TASK.'        30680000
*                                                                       30810000
*        REAL MOTHER TASK ..                                            30940000
*                                                                       31070000
*                                                                       31200000
*        FUNCTIONS ..                                                   31330000
*                                                                       31460000
*        1.    OWNS THE MOTHER TCB (AND THEREFORE THE DAUGHTER TASK)    31590000
*        AND THE FOLLOWING ECBS ..   ECBMERE,  ECBAPL .                 31720000
*                                                                       31850000
*        2.    RAISES AND LOWERS THE PRIORITY OF THE DAUGHTER TASK      31980000
*        ON REQUEST FROM APLSUP.                                        32110000
*        THIS IS DONE HERE RATHER THAN IN APLSUP TO ELIMINATE THE       32240000
*        POSSIBILITY OF A TASK SWITCH WHILE IN APLSUP.  A TASK SWITCH   32370000
*        MAY OCCUR IN MOTHER.                                           32500000
*                                                                       32630000
*        3.    MAY EXECUTE CONCURRENTLY WITH THE DAUGHTER TASK          32760000
*        (WHICH, AT TIMES, IS APLSUP), AND REFERENCES GLOBAL VARIABLES. 32890000
*                                                                       33020000
MOTHER   WAIT  ECBLIST=ECBLIST = ECBMERE,ECBAPL,REPLYECB           C046 33150000
         XC    ECBMERE,ECBMERE                                     C046 33280000
*                                                                       33410000
*        DISPATCHED BY EXINT, MPXINT, OR SHUTDOWN.                      33540000
***      NOTE..  R10 WILL BE DESTROYED IN APLSUP.                       33670000
*                                                                       33800000
         TM    ECBAPL,X'40'        SEE IF APL TERMINATED            K03 33930000
         BO    DETACH              BRANCH IF SO.                        34060000
         TM    REPLYECB,X'40' HAS THE OPERATOR REQUESTED A CANCEL?  K11 34190000
         BO    CANCEL                                               K11 34320000
         CLC   CHAPCODE,=H'0'      SEE IF APLSUP REQUESTED A CHAP.      34450000
         BE    MOTHER              BRANCH IF NOT.                       34580000
         LH    0,CHAPCODE          OTHERWISE,                           34710000
         MVC   CHAPCODE(2),=H'0'   RESET CHAPCODE,                      34840000
         CHAP  (0),TCBFILLE        AND CHANGE DAUGHTER PRIORITY.        34970000
         B     MOTHER                                                   35100000
         SPACE 3                                                    K11 35230000
CANCEL   OC    REPLY(9),=CL9' '    FOLD TO UPPER CASE               K11 35360000
         WTO   MF=(E,REPLYWTO) PUT OPERATORS REPLY ON SMB'S         K11 35490000
         CLC   REPLY(9),=C'ABEND APL'                               K11 35620000
         BE    CANCELIT                                                 35750000
         XC    REPLY(9),REPLY CLEAR REPLY BUFFER                    K11 35880000
         XC    REPLYECB,REPLYECB                                    K11 36010000
         B     REQC           TELL HIM HOW TO SPELL IT              K11 36140000
         SPACE 2                                                    K11 36270000
REPLYWTO DS    0F                                                   K11 36400000
         DC    AL2(REPLYZ-*),XL2'8000'                              K11 36530000
         DC    CL8'APL'       MESSAGE PREFIX                            36660000
REPLY    DC    CL9' '                                               K11 36790000
REPLYZ   EQU   *                                                    K11 36920000
         DC    XL4'00000020'  ROUTCDE=(11)                          K11 37050000
REPLYECB DC    F'0'           ECB FOR FAKE OPERATOR CANCEL          K11 37180000
         TITLE 'A P L   M O T H E R  -  APL TERMINATION.'               37310000
*                                                                       37440000
*        APL TERMINATION, RESTORE IO NEW PSW AND DETACH APL.            37570000
*                                                                       37700000
DETACH   BAL   14,RSTR        RESTORE THE I/O NEW PSW               K02 37830000
DETACH1  CLC   ECBAPL+1(3),=FL3'21'                                     37960000
*  RETURN CODES ARE:                                                K03 38090000
*      0 NORMAL APL SHUTDOWN                                        K03 38220000
*      4 INSUFFICIENT CORE STORAGE                                  K03 38350000
*      8 VERSION MISMATCH                                           K03 38480000
*     12 TIMER NOT INCREMENTING                                     K03 38610000
*     16 BLDL  FOR APPENDAGES FAILED.                                   38740000
*     24 INVALID OPERAND IN PARM FIELD OF EXEC CARD                P062 38870000
*     20 NOT OS-MVT  OR  OS-MFT-ATTACH                                  39000000
*                                                                   K03 39130000
         BNL   ABEND          B. IF INVALID COMPLETION CODE         K03 39260000
*                                (OR IF SUBTASK ABENDED.)           K03 39390000
         TM    ECBAPL+3,X'03'      IS CC A MULTIPLE OF 4?           K03 39520000
         BNZ   ABEND                                                K03 39650000
         DETACH TCBFILLE    LET OS GET RID OF THE TCB FOR DAUGHTER  K03 39780000
*                                                                       39910000
*        NORMAL TERMINATION OF APL.                                     40040000
*                                                                       40170000
GOTOOS   DEQ   (QNAME,RNAME,,SYSTEM) RELEASE APL UTILITY.               40300000
         LH    15,ECBAPL+2    PUT SUBTASK RETURN CODE INTO R15      K03 40430000
RETURN   L     13,OSR13      RESTORE REGS                          P062 40560000
         RETURN (14,12),RC=(15)    RETURN TO OS, RETURN CODE IN R15 K03 40690000
         SPACE 3                                                        40820000
*                                                                       40950000
*        ABNORMAL TERMINATION OF APL.                                   41080000
*        APL HAS EITHER ..                                              41210000
*        1.    ABENDED:  PROGRAM CHECK IN SUPERVISOR STATE              41340000
*                        APLSOPEN                                  C046 41470000
*                        APLSSINI                                  C046 41600000
*                        UGH IN APLSASUP                                41730000
*        2.    TERMINATED FROM SUPINI WITH A RETURN-CODE            K03 41860000
*              GREATER THAN 20.                                     K03 41990000
*                                                                       42120000
         SPACE                                                          42250000
ABEND    UNPK  SAB(3),ECBAPL+1(2)  UNPACK SYSTEM COMPLETION CODE   C047 42380000
         OI    SAB+2,C'0'          'FIX' SIGN                      C047 42510000
         TR    SAB(3),HEXTAB       CONVERT TO PRINTABLE HEX        C047 42640000
         LA    14,X'FFF'           MASK FOR USER COMPLETION CODE   C047 42770000
         N     14,ECBAPL           EXTRACT                         C047 42900000
         CVD   14,ABEND2F          INTO PACKED DECIMAL             C047 43030000
         UNPK  UAB(4),ABEND2F+5(3) UPACK                           C047 43160000
         OI    UAB+3,C'0'    SET PROPER ZONE BITS.                 C047 43290000
         WTO   MF=(E,ABENDMSG)      SEND WORD TO OPERATOR          C047 43420000
         ABEND 1000,DUMP           FINI                            C047 43550000
         SPACE 3                                                   C047 43680000
ABEND2F  DS    D              TEMP FOR CVD AT 'ABEND'              C047 43810000
*        WTO   'ABNORMAL APL SUBTASK TERMINATION, S=***, U=****',  C047 43940000
*              ROUTCDE=(1,11)                                      C047 44070000
ABENDMSG DC    0F'0',AL2(ABENDMSZ-ABENDMSG),XL2'8000' WITH ROUTCDE C047 44200000
         DC    CL8'APL'                                            C047 44330000
         DC    C'ABNORMAL APL SUBTASK TERMINATION, S='             C047 44460000
SAB      DC    C'***'              SYSTEM COMPLETION CODE          C047 44590000
         DC    C', U='                                             C047 44720000
UAB      DC    C'****',C'.'        USER COMPLETION CODE            C047 44850000
ABENDMSZ DC    X'00008020'         ROUTCDE=(1,11)                  C047 44980000
         SPACE 3                                                        45110000
*        NON-ZERO RETURN CODE FROM STAE                                 45240000
*                                                                       45370000
STAERR   LA    15,1100(15)    BUILD ABEND CODE                          45500000
         ABEND (15)                                                     45630000
         SPACE 3                                                        45760000
CANCELIT ABEND 1020,DUMP,STEP OPERATOR REQUESTED 'ABEND APL'            45890000
         DROP  12                                                       46020000
         TITLE 'A P L   M O T H E R  -  TIMER COMPLETION EXIT ROUTINE.' 46150000
*                                                                       46280000
*        TIMER COMPLETION EXIT ROUTINE.                                 46410000
*        THIS CODE MUST BE IN SUPERVISOR STATE, KEY OF ZERO, DISABLED.  46540000
*                                                                       46670000
*                                                                       46800000
*              A REQUEST BLOCK (TQE) FOR THIS ROUTINE IS ALWAYS ON      46930000
*        THE MOTHER TCB.  IT IS POSSIBLE TO ALSO HAVE A TQE FOR IT      47060000
*        ON THE DAUGHTER TCB.. E.G. WHEN SETINT IS CALLED FROM QZA3.    47190000
*              WHEN A TIMER QUEUE ELEMENT EXISTS ON BOTH TCBS, THE      47320000
*        DUE TIME FOR THE DAUGHTER WILL BE LESS THAN OR EQUAL THE       47450000
*        TIME DUE FOR THE MOTHER.                                       47580000
*        THE RELATIONSHIP IS A FAIRLY COMPLEX FUNCTION OF APL LOADING.  47710000
*                                                                       47840000
*                                                                       47970000
*        1.    GOTO 3 IF ECBMERE NE WAIT                                48100000
*        2.    POST ECBMERE                                             48230000
*        3.    GOTO 0 IF ECBAPL = COMPLETE                              48360000
*        4.    GOTO 0 IF EXINTLK NE 0                                   48490000
*        5.    APLEXOLD IS RBMERE.(RBOPSW).                             48620000
*        6.    RBMERE.(RBOPSW). IS X'00040000',A(EXINT)                 48750000
*                                                                       48880000
*                                                                       49010000
APLTCXR  STM   13,12,8(13)    OS PROVIDES A STANDARD SAVE AREA      K06 49140000
*                   ALTHOUGH NON-STANDARD, SAVING REG.13 AS ABOVE   K06 49270000
*                   SHOULD NOT CAUSE ANY TROUBLE, SINCE THIS SAVE   K06 49400000
*                   AREA WILL NOT BE CHAINED TO ANYTHING ELSE.      K06 49530000
*                                                                   K06 49660000
         LR    7,13           SAVE 13 SO REGISTERS CAN BE RESTORED  K06 49790000
         LR    8,15                POST  WIPES A LOT OF REGS        MFT 49920000
         USING APLTCXR,8                                            MFT 50050000
* 1.                                                                    50180000
         TM    ECBMERE,X'80'       SEE IF MOTHER IS WAITING.            50310000
         BZ    NOPOST              BRANCH IF NOT.                       50440000
* 2.                                                                    50570000
         L     1,RBMERE            MAKE SURE KEY IS KEY OF REGION.      50700000
         USING IRB,1                                                    50830000
         OC    RBOPSW+1(1),SK      REGION'S STORAGE KEY.                50960000
*                                                                       51090000
*        POST THE MOTHER TASK -- THE BRANCH ENTRY IS USED.              51220000
*                                                                   K06 51350000
*        REGISTERS  0-9 ARE TRANSPARENT IN MVT                      MFT 51480000
*        REGISTERS  0-8  ARE TRANSPARENT IN MFT                     MFT 51610000
*                                                                   K06 51740000
*        REGISTERS 10-13,15  ARE *VOLATILE*                         K06 51870000
*                                                                   K06 52000000
*        REG.  REQUIRED DATA ( PARAMETERS FOR POST )                K06 52130000
*                                                                   K06 52260000
*        R10 - ZERO (POST CODE).                                        52390000
*        R11 - ECBMERE                                                  52520000
*        R12 - TCBMERE                                                  52650000
*        R14 - RETURN ADDRESS.                                          52780000
*        R15 - POST ROUTINE ENTRY ADDRESS.                              52910000
*                                                                       53040000
         SR    10,10               ZERO POST CODE.                      53170000
         LA    11,ECBMERE          MOTHER ECB.                          53300000
         L     12,TCBMEREA         MOTHER TCB.                          53430000
         L     15,CVT              CVT POINTER.                         53560000
         USING CVTD,15                                                  53690000
         L     15,CVT0PT01                                              53820000
         DROP  15                                                       53950000
         BALR  14,15                                                    54080000
* 3.                                                                    54210000
NOPOST   L     1,RBMERE            MOTHER PRB.                          54340000
         MVC   RBOPSW(2),=X'0004' DISABLED,KEY 0,SUP.STATE,        3054 54470000
         TM    ECBAPL,X'40'        SEE IF APL IS STILL RUNNING.         54600000
         BO    TCXRX          BRANCH IF APL NOT RUNNING             MFT 54730000
* 4.                                                                    54860000
*                                                                       54990000
*        THE FOLLOWING TEST ALLOWS THE TIMER COMPLETION EXIT ROUTINE    55120000
*        TO BE ENTERED MORE OFTEN THAN APLSUP TIMER CODE.               55250000
*                                                                       55380000
*                                                                       55510000
         L     2,=A(EXINTLK)       TEST AND SET INTERLOCK.              55640000
         TS    0(2)                                                     55770000
         BC    4,TCXRX        BRANCH IF LAST INTERRUPT STILL            55900000
*                                  OUTSTANDING.                         56030000
* 5.                                                                    56160000
         L     2,EXTOLD            APLSUP EXTERNAL OLD.                 56290000
         MVC   0(8,2),RBOPSW                                            56420000
* 6.                                                                    56550000
         MVC   RBOPSW,EXINTPSW                                          56680000
* FOR MVT ONLY                                                      MFT 56810000
*         RESET RBDYN FLAGS IN TQE ALIAS IRB SO THAT EXIT (SVC 3) WILL  56940000
*        NOT ATTEMPT TO RETURN IT TO FREE QUEUE SPACE.                  57070000
TCXRX    L     1,TCBMEREA                                           MFT 57200000
         L     1,0(1)                                                   57330000
         NI    RBSTAB+1,X'F9'      DONT LET EXIT FREE TQE/IRB           57460000
*                             OR SAVE AREA                              57590000
* ABOVE 3 INSTRUCTIONS FOR MVT ONLY                                 MFT 57720000
TCXRF    LM    13,12,8(7)     RETRIEVE ALL REGS. INCLUDING 13       MFT 57850000
         BR    14                  AND RETURN TO MVT.                   57980000
TCXRZ    EQU   *                                                    MFT 58110000
         DROP  8,1                                                  MFT 58240000
         EJECT                                                      MFT 58370000
         TITLE 'A P L   M O T H E R  -  INTERFACE.'                     58500000
*    TASK ABEND EXIT ROUTINE (STAE)                                     58630000
*        RESET THE IO NEW PSW TO ITS VALUE BEFORE INITIALIZATION,       58760000
*        DEQ   FOR RUN OF APL UTILITY, AND LEAVE.                       58890000
         SPACE 3                                                        59020000
*    REGISTER CONTENTS AT ENTRY TO STEP                                 59150000
*                                                                       59280000
*      0  ACTIVE I/O FLAG                                               59410000
*      1  104 BYTE STAE WORK AREA OR ABEND CODE                         59540000
*      2    *                                                           59670000
*      . TO ** UNPREDICTABLE                                            59800000
*     12    *                                                           59930000
*     13  ADDRESS OF SUPERVISOR PROVIDED SAVE AREA                      60060000
*     14  RETURN ADDRESS                                                60190000
*     15  E.P. OF STAE EXIT (I.E. A(STEP))                              60320000
*                                                                       60450000
         DS    0D                  FOR EASY IAR STOPPING.               60580000
STEP     LR    12,15                                                    60710000
         USING STEP,12                                                  60840000
         STM   13,14,STSAV                                              60970000
*                                                                       61100000
         L     11,ACURRENT    XENOPHOBIC SVC ROUTINE                    61230000
         L     11,0(11)                                                 61360000
         SVRAPE                                                         61490000
         BAL   14,RSTR        RESTORE THE I/O NEW PSW               K02 61620000
         DEQ   (QNAME,RNAME,,SYSTEM)                                    61750000
         LM    13,14,STSAV                                              61880000
         DROP  12                                                       62010000
         SR    15,15               INDICATE NO RESTART.                 62140000
         BR    14                  TO SVC 3                             62270000
         TITLE   'PSW RESTORE SUBROUTINE (MODIFIED LMB CONVENTION)' K02 62400000
*                                                                   K02 62530000
*                                                                   K02 62660000
*   THIS ROUTINE SEARCHES THE PSW CHAIN (ASSUMING THE MODIFIED LMB  K02 62790000
*        CONVENTION WAS BEING USED) AND MODIFIES THE I/O NPSW CHAIN K02 62920000
*        TO REMOVE APL FROM THE CHAIN.                              K02 63050000
*                                                                   K02 63180000
*   DESTROYS 14,15; USES MVTSAVE AS REGISTER SAVE AREA              K02 63310000
*                                                                   K02 63440000
RSTR     BALR  15,0           ESTABLISH TEMPORARY ADDRESSIBILITY    K02 63570000
         USING *,15                                                 K02 63700000
         STM   12,3,MVTSAVE+12 USE STANDARD SAVE AREA IN A          K02 63830000
*                             NON-STANDARD WAY                      K02 63960000
*                                                                   K02 64090000
*                                                                   K02 64220000
*   CHECK TO SEE IF THE PSW NEEDS TO BE RESTORED                    K02 64350000
*        I.E.  HAS IT EVER BEEN STOLEN, OR                          K02 64480000
*        HAS IT ALREADY BEEN RESTORED.                              K02 64610000
*              THE ABOVE CONDITION IS POSSIBLE IF THERE IS AN ABEND K02 64740000
*              CONDITION THAT IS FIRST RECOGNIZED BY THE CHECK ON   K02 64870000
*              THE ABEND CODE AT DETACH1                            K02 65000000
*              OR IF THERE WAS A NON-ZERO RETURN CODE FROM STIMER   K02 65130000
*                                                                   K02 65260000
         NC    OSIONEW,OSIONEW     IS THIS ZERO?                    K02 65390000
         BCR   8,14  BZR      B. IF NOT STOLEN                      K02 65520000
         LR    12,15                                                K02 65650000
         DROP  15                                                   K02 65780000
         USING RSTR+2,12                                            K02 65910000
*                                                                   K02 66040000
*   REGISTER USAGE                                                  K02 66170000
*                                                                   K02 66300000
*        0     ADDRESS OF E.P. FOR APL INTERRUPT HANDLER            K02 66430000
*        1     POINTER TO NPSW BEING EXAMINED                       K02 66560000
*        2     LOOP PROTECTION COUNTER                              K02 66690000
*        3     CVT                                                  K02 66820000
*                                                                   K02 66950000
*        12    BASE                                                 K02 67080000
*        14    RETURN ADDRESS                                       K02 67210000
*        15    CONSTANT (-12) AND POINTER TO APL-SAVED NPSW         K02 67340000
*                                                                   K02 67470000
         LA    2,16           LOOP PROTECT COUNTER; ASSUME NO MORE  K02 67600000
*                             THAN 16 TASKS STOLE THE I/O NEW PSW   K02 67730000
         L     1,APLIONEW     THIS IS ADDRESS OF STOLEN PSW WHICH   K02 67860000
*                        OCCUPIES THE 8 BYTES PREDEEDING THE E.P.   K02 67990000
*                             TO THE APL I/O INTERRUPT HANDLER      K02 68120000
         LA    0,8(1)         GET ADDRESS OF E.P.                   K02 68250000
         LH    15,=H'-12'     GET CONSTANT USED IN LOOP             K02 68380000
         LA    1,IONEWPSW-4   PRIME THE PUMP                        K02 68510000
         L     3,CVT                                                K02 68640000
         USING CVTD,3                                               K02 68770000
         B     RSTRLQQP       SKIP COMPARE FOR =C'PSW'              K02 68900000
         SPACE 2                                                    K02 69030000
RSTRLOOP AR    1,15           BACK UP THE PSEUDO NPSW ADDRESS       K02 69160000
         CLC   0(3,1),=CL3'PSW' DOES IT SAY 'PSW'?                  K02 69290000
         BNE   RSTRERR                                              K02 69420000
RSTRLQQP CL    0,8(1)         HAVE WE FOUND OURSELVES               K02 69550000
         BE    RSTRIT                                               K02 69680000
*                                                                   K02 69810000
*   ERROR CHECKING                                                  K02 69940000
*                                                                   K02 70070000
         TM    11(1),X'03'    IS NEXT ON FULL WORD BOUNDARY         K02 70200000
         BNZ   RSTRERR        B. IF NOT FULL WORD BOUNDARY          K02 70330000
*                                                                   K02 70460000
         L     1,8(1)         GET THIS PORTION OF THIS PSW FOR      K02 70590000
*                      USE AS THE NEW PSW POINTER                   K02 70720000
         SPACE 1                                                    K02 70850000
*?       C     1,CVTNUCB      IS THIS IN DYNAMIC CORE AREA?         K02 70980000
*?       BNH   RSTRERR        B. IF IN NUCLEUS OR SQS               K02 71110000
         SPACE 1                                                    K02 71240000
         C     1,CVTMZ00      DOES THIS EXCEED CORE SIZE            K02 71370000
         BNL   RSTRERR                                              K02 71500000
         BCT   2,RSTRLOOP     FEWER THAN 16 THIEVES?                K02 71630000
*                                                                   K02 71760000
*                                                                   K02 71890000
* AT LEAST ONE PROGRAM CURRENTLY RUNNING                            K02 72020000
*  DID NOT FOLLOW THE MODIFIED LMB CONVENTION                       K02 72150000
*                                                                   K02 72280000
*IN ORDER TO AVOID ABENDING, WE WILL TAKE RELATIVELY DRASTIC ACTION K02 72410000
*                                                                   K02 72540000
RSTRERR  AR    15,0                                                 K02 72670000
         MVC   IONEWPSW(8),4(15)   JAM IT BACK, SOMEONE MAY HAVE    K02 72800000
*                      GOTTEN STRANDED                              K02 72930000
         B     RSTREX                                               K02 73580000
         SPACE 3                                                    K02 73710000
*                                                                   K02 73840000
*   BY SCANNING THE PSW'S IN THE CHAIN  OF STOLEN PSW'S WE          K02 73970000
*        HAVE FOUND THE PSW THAT POINTS TO US.                      K02 74100000
*        IT WILL BE REPLACED BY THE PSW WE HAVE STOLEN,             K02 74230000
*        THEREBY REMOVING APL FROM THE CHAIN                        K02 74360000
*                                                                   K02 74490000
RSTRIT   AR    15,0                                                 K02 74620000
         MVC   4(8,1),4(15) TAKE APL OUT OF THE CHAIN OF PSW THIEFS K02 74750000
         SPACE 2                                                    K02 74880000
RSTREX   XC    OSIONEW,OSIONEW     CLEAR THE 'SWITCH'               K02 75010000
         LM    12,3,MVTSAVE+12     PSW RESTORE IS COMPLETE          K02 75140000
         BR    14                                                   K02 75270000
         SPACE 3                                                    K02 75400000
         DROP  3,12                                                 K02 75530000
         TITLE '     C O N S T A N T S    ETC.'                         75660000
*                                                                       75790000
*    PARAMETER LISTS FOR ATTACH                                     K05 75920000
*                                                                   K05 76050000
PARAM    DC    A(TOLIST,ALIST)  SECOND WORD IN LIST IS CHANGED BY   K05 76180000
*                                     SUPINI                        K05 76310000
         DC    A(X'800000')   ADDRESS OF EXEC PARM FIELD GOES HERE      76440000
         DC    A(SELPCIX,SELCE,SELXEN)  APL APPENDAGES                  76570000
         EXTRN   SELPCIX,SELCE,SELXEN                                   76700000
*                                                                   K06 76830000
*    MULTIPLE WAIT ECBLIST                                          K06 76960000
*                                                                   K06 77090000
ECBLIST  DC    A(ECBMERE)     ECB POSTED BY APL SUBTASK FOR CHAP    K06 77220000
         DC    A(REPLYECB)    FAKE OPERATOR CANCEL                  K11 77350000
         DC    X'80',AL3(ECBAPL) POSTED BY OS IF SUBTASK TERMINATES K06 77480000
*                                                                   K06 77610000
         SPACE 3                                                    K20 77740000
*        CONSTANTS ETC.                                                 77870000
*                                                                       78000000
ALIST    DS    0F                  ADDRESS LIST PASSED BY SUOINI.       78130000
ECBINIT  DS    F                   POINTER TO SUPINI'S ECB.             78260000
OSFLG    DC    X'00'          MVT/MFT FLAGS                         MFT 78390000
MFT      EQU   X'20'                                                MFT 78520000
MVT      EQU   X'10'                                                MFT 78650000
KEY2     DC    X'00'          ACTKEY                                MFT 78780000
ALISTZ   EQU   *                                                        78910000
APLSGENE DC    A(TCBMERE)          APLSUP GENEOLOGY LIST.               79040000
APLIONEW DC    A(HOSTIOP)          APLSUP IO NEW PSW.                   79170000
SVOLDPA  DC    A(SVOLDPSW)         APLSUP SVC OLD PSW.                  79300000
EXTOLD   DC    A(EXOLDPSW)         APLSUP EXTERNAL OLD PSW.             79430000
         SPACE                                                          79560000
         EXTRN ATQE                                                     79690000
ATQEX    DC    A(ATQE)                                                  79820000
MVTSAVE  DC    18F'0'              OS PROBLEM PROGRAM SAVE AREA.        79950000
OSR13    EQU   MVTSAVE+4                                                80080000
         SPACE                                                          80210000
*        THE FOLLOWING EIGHT WORDS ARE THE SUBJECT OF AN MVC.           80340000
TCBMEREA DS    F                   ADDRESS OF MOTHER'S TCB.             80470000
TCBFILLE DS    F                   ADDRESS OF DAUGHTER TCB.             80600000
RBMERE   DS    F                   ADDRESS OF MOTHER PRB.               80730000
RBFILLE  DS    F                   ADDRESS OF DAUGHTER PRB.             80860000
         DC    A(ECBMERE)          ADDRESS OF MOTHER ECB.               80990000
ECBFILLE DC    F'0'                DAUGHTER ECB.                        81120000
GENEZ    EQU   *                                                        81250000
         SPACE                                                          81380000
ECBAPL   DC    F'0'                ECB FOR ATTACH.                      81510000
ECBMERE  DC    F'0'                MOTHER ECB.                          81640000
EXINTPSW DC    X'FF040000'                                         3054 81770000
EXINTA   DC    A(EXINT)            ENTRY POINT FOR APLSUP EXTERNAL INTS 81900000
OSIONEW  DC    XL8'00'        OS I/O NEW PSW                        MFT 82030000
TWOSEC   DC    A(2*300*128)        TWO SECOND INTERVAL.                 82160000
         ENTRY CHAPCODE                                                 82290000
CHAPCODE DC    H'0'                                                     82420000
SK       DC    X'00'               STORAGE KEY OF REGION.               82550000
QNAME    DC    C'APLOS360'                                              82680000
RNAME    DC    C'LIBRARIES'                                             82810000
STSAV    DS    2F                                                       82940000
         SPACE 3                                                   P062 83070000
ATTACHL  ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8,HIARCHY=1      P062 83200000
         SPACE 2                                                   P062 83330000
ATTACHH1 EQU   ATTACHL+4      POINT TO HIARCHY FLAG BYTE           P062 83460000
         SPACE 3                                                   P062 83590000
ATTACHD  DSECT                                                     P062 83720000
         SPACE 2                                                   P062 83850000
*        THESE TWO EXPANSIONS OF  ATTACH  ARE SHOWN TO ALLOW       P062 83980000
*        THE DEBUGGER TO DETERMINE THE POSSIBLE STATES OF          P062 84110000
*        THE  ATTACHH1  FIELD IN THE  ATTACH PARAMETER LIST        P062 84240000
         SPACE 2                                                   P062 84370000
         ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8,HIARCHY=0      P062 84500000
         SPACE 2                                                   P062 84630000
         ATTACH SF=L,EP=APLSINIT,ECB=ECBAPL,LPMOD=8                P062 84760000
APLOS    CSECT                                                     P062 84890000
         SPACE 3                                                   P062 85020000
HEXTAB   EQU   *-C'0'                                                   85150000
         DC    CL16'0123456789ABCDEF'                                   85280000
         EJECT                                                          85410000
*                                                                       85540000
*        ADDRESS LIST FOR SUPINI.                                       85670000
*                                                                       85800000
*        REQUIRED BECAUSE EXTERNAL REFFERENCES BETWEEN                  85930000
*        ATTACHING AND ATTACHED PROGRAMS ARE NOT RESOLVED.              86060000
*                                                                       86190000
*        NOTE ...                  SUPINI ASSUMES ORDERING.             86320000
*                                                                       86450000
         SPACE                                                          86580000
TOLIST   DS    0A                                                       86710000
ASUPPARS DC    A(SUPPARS)                                               86840000
ACONFINI DC    A(CONFINIT)                                              86970000
ATYI1052 DC    A(TYI1052)                                               87100000
AHISTKI  DC    A(HISTKILL)                                              87230000
ASWAPPAR DC    A(SWAPPARS)                                              87360000
ACONFSWA DC    A(CONFSWAP)                                              87490000
AHTAB    DC    A(HTAB)                                                  87620000
ADIRTAB  DC    A(DIRTAB)                                                87750000
ALIBPZ   DC    A(LIBPZ)                                                 87880000
ALIBPARS DC    A(LIBPARS)                                               88010000
AAPLSDCB DC    A(APLSDCBS)                                              88140000
AZSYMDAT DC    A(ZSYMDATE)                                              88270000
APCSUB   DC    A(PCSUB)                                                 88400000
MOMMY    DC    A(ECBMERE)                                               88530000
ASVOLDPS DC    A(SVOLDPSW)                                              88660000
ASVINT   DC    A(SVINT)                                                 88790000
LISTLENG EQU   *-TOLIST            CHECK AGAINST LIST IN SUPINI.        88920000
ACURRENT DS    A                   SUPINIT FILLS IN. DON'T MOVE.        89050000
ASTEP    DC    A(STEP)                                                  89180000
         EJECT                                                          89310000
         EXTRN APLINIT                                                  89440000
         EXTRN APLSDCBS                                                 89570000
         EXTRN CHAPLOW                                                  89700000
         EXTRN CONFINIT                                                 89830000
         EXTRN CONFSWAP                                                 89960000
         EXTRN CURRENTM                                                 90090000
         EXTRN DIRTAB                                                   90220000
         EXTRN EXINT                                                    90350000
         EXTRN EXINTLK                                                  90480000
         EXTRN EXOLDPSW                                                 90610000
         EXTRN HISTKILL                                                 90740000
         EXTRN HOSTIOP                                                  90870000
         EXTRN HTAB                                                     91000000
         EXTRN LIBPARS,LIBPZ                                            91130000
         EXTRN PCSUB                                                    91260000
         EXTRN SUPPARS                                                  91390000
         EXTRN SVINT                                                    91520000
         EXTRN SVOLDPSW                                                 91650000
         EXTRN SWAPPARS                                                 91780000
         EXTRN TCBMERE                                                  91910000
         EXTRN TYI1052                                                  92040000
         EXTRN ZSYMDATE                                                 92170000
         SPACE                                                          92300000
TCBRBP   EQU   0                   DISPLACEMENT OF PRB ADDRESS IN TCB.  92430000
TCBPKE   EQU   28                  DISPLACEMENT OF STORAGE KEY IN TCB.  92560000
TCBDSP   EQU   35                  DISPATCHING PRIORITY BYTE IN TCB.    92690000
IONEWPSW EQU   120                 LOCATION OF REAL IO NEW PSW.         92820000
         SPACE                                                          92950000
         LTORG                                                          93080000
         COPY  TQE                                                      93210000
         COPY  IRB                                                      93340000
CVTD     DSECT                                                          93470000
CVT      EQU   16             LOCATION OF CVT POINTER                   93600000
         CVT                                                            93730000
         DCBD  DSORG=XA                                                 93860000
         END                                                            93990000
./  ADD    NAME=APLSAPPN
APPENDAG CSECT                                                          12500000
         USING *,15           IOS SETS UP R15                           25000000
         L     15,ADDR        WHERE TO GO NEXT                          37500000
         BR    15                                                       50000000
BR14     BR    14             BACK TO IOS                               62500000
ADDR     DC    A(BR14)        NORMALLY, JUST GO BACK TO IOS             75000000
         END                                                            87500000
./  ADD    NAME=APLSARTH
ARTH     TITLE 'ARITHMETIC TYPE TABLES                        05/11/70' 00230000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00460000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00690000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00920000
         MACRO                                                          01150000
&OP      ARTHTYPE &TYPE1,&TYPE2,&TYPE3,&TYPE4                           01380000
         ORG   ARTHTAB+4*Z&OP+2                                         01610000
         DC    AL1(&TYPE1)                                              01840000
         AIF   (T'&TYPE2 EQ 'O').OMIT2                                  02070000
         DC    AL1(&TYPE2)                                              02300000
         AGO   .TRY3                                                    02530000
.OMIT2   DC    AL1(&TYPE1)                                              02760000
.TRY3    AIF   (T'&TYPE3 EQ 'O').OMIT3                                  02990000
         DC    AL1(&TYPE3)                                              03220000
         AGO   .TRY4                                                    03450000
.OMIT3   AIF   (T'&TYPE2 EQ 'O').USE13                                  03680000
         DC    AL1(&TYPE2)                                              03910000
         AGO   .TRY4                                                    04140000
.USE13   DC    AL1(&TYPE1)                                              04370000
.TRY4    AIF   (T'&TYPE4 EQ 'O').OMIT4                                  04600000
         DC    AL1(&TYPE4)                                              04830000
         MEXIT                                                          05060000
.OMIT4   AIF   (T'&TYPE3 EQ 'O').USE24                                  05290000
         DC    AL1(&TYPE3)                                              05520000
         MEXIT                                                          05750000
.USE24   AIF   (T'&TYPE2 EQ 'O').USE14                                  05980000
         DC    AL1(&TYPE2)                                              06210000
         MEXIT                                                          06440000
.USE14   DC    AL1(&TYPE1)                                              06670000
         MEND                                                           06900000
*                                                                       07130000
         MACRO                                                          07360000
&OP      DYADICOP &FIX,&FLOAT                                           07590000
         ORG   DYADTAB+8*Z&OP+4                                         07820000
         DC    A(&FIX)                                                  08050000
         AIF   ('&FIX' EQ 'EXERROR').NOX                                08280000
         EXTRN &FIX                                                     08510000
.NOX     AIF   (T'&FLOAT EQ 'O').UFIX                                   08740000
         DC    A(&FLOAT)                                                08970000
         AIF   ('&FLOAT' EQ 'EXERROR').NOFX                             09200000
         EXTRN &FLOAT                                                   09430000
.NOFX    MEXIT                                                          09660000
.UFIX    DC    A(&FIX)                                                  09890000
         MEND                                                           10120000
*                                                                       10350000
         MACRO                                                          10580000
&OP      MONADOP &FIX,&FLOAT                                            10810000
         ORG   MONADTAB+8*Z&OP+4                                        11040000
         DC    A(&FIX)                                                  11270000
         AIF   ('&FIX' EQ 'EXERROR').NOX                                11500000
         EXTRN &FIX                                                     11730000
.NOX     AIF   (T'&FLOAT EQ 'O').UFIX                                   11960000
         DC    A(&FLOAT)                                                12190000
         AIF   ('&FLOAT' EQ 'EXERROR').NOFX                             12420000
         EXTRN &FLOAT                                                   12650000
.NOFX    MEXIT                                                          12880000
.UFIX    DC    A(&FIX)                                                  13110000
         MEND                                                           13340000
         SPACE                                                          13570000
         MACRO                                                          13800000
&OP      OPTYPE &MTYPE,&DTYPE,&MNDX,&DNDX                               14030000
         LCLB  &MX,&DX                                                  14260000
         ORG   INDICTR+2*Z&OP+1                                         14490000
         AIF   (T'&MNDX EQ 'O').MNO                                     14720000
&MX      SETB  ('&MNDX' EQ 'INDEXED')                                   14950000
.MNO     AIF   (T'&DNDX EQ 'O').DNO                                     15180000
&DX      SETB  ('&DNDX' EQ 'INDEXED')                                   15410000
         AGO   .TYPES                                                   15640000
.DNO     ANOP                                                           15870000
&DX      SETB  (&MX)                                                    16100000
.TYPES   AIF   (T'&DTYPE EQ 'O').DNOT                                   16330000
         DC    AL1(&MTYPE+&MX*X'80',&DTYPE+&DX*X'80')                   16560000
         MEXIT                                                          16790000
.DNOT    ANOP                                                           17020000
         DC    AL1(&MTYPE+&MX*X'80',&MTYPE+&DX*X'80')                   17250000
         MEND                                                           17480000
         MACRO                                                          17710000
         IDEL  &OP,&TYPE,&FU1,&FU2,&FU3                                 17940000
         ORG   IDENTS+Z&OP*8                                            18170000
         USING *,9                                                      18400000
         &FU1  &FU2,&FU3                                                18630000
         DC    A(&TYPE)                                                 18860000
         MEND                                                           19090000
*                                                                       19320000
         PRINT OFF       APLDEFN, ZSYMBOLS                              19780000
ARTHTYP CSECT                                                           20010000
         COPY  APLDEFN                                                  20240000
         COPY  ZSYMBOLS                                                 20470000
         PRINT GEN                                                      20700000
         TITLE 'ARITHMETIC TYPE TABLES                        05/11/70' 20930000
         PRINT ON,NOGEN                                                 21160000
ARTHTYP  CSECT                                                          21390000
*                                                                       21620000
*********************************************************************** 21850000
*                                                                       22080000
*        ARTHTP                                                         22310000
*                                                                       22540000
*********************************************************************** 22770000
*                                                                       23000000
*                                                                       23230000
*        DETERMINE COMPUTE TYPE, RESULT TYPE, FETCH CODES, AND          23460000
*        EXECUTION ROUTINE ADDRESS.                                     23690000
*                                                                       23920000
*        R0 - 0 - COMPUTE TYPE.                                         24150000
*            - TYPE - FORCE RESULT TO THIS TYPE.                        24380000
*                                                                       24610000
         SPACE                                                          24840000
         ENTRY ARTHTP                                                   25070000
         EXTRN ERROR                                                    25300000
         EXTRN EXERROR                                                  25530000
ARTHTP PROLOG                                                           25760000
         SPACE                                                          25990000
         LTR   2,2                 SEE IF THERE'S AN LH OPERAND.        26220000
         BZ    *+8                 BRANCH IF NOT.                       26450000
         LA    1,1(1)              OTHERWISE, INCREMENT OP BY 1.        26680000
         AR    1,1                 THEN MAKE IT A WORD INDEX.           26910000
         SR    5,5                                                      27140000
         LA    6,ARTHTAB(1)        CHECK FOR CHARACTER TYPE ALLOWED.    27370000
         TM    0(6),NOCHAR                                              27600000
         BZ    CHAROK              BRANCH IF SO.                        27830000
         C     2,OC4               OTHERWISE, EXAMINE TYPES.            28060000
         BE    RNGEROR             RANGE ERROR IF CHAR.                 28290000
         C     3,OC4               RIGHT HAND.                          28520000
         BE    RNGEROR                                                  28750000
CHAROK   SR    5,5                                                      28980000
         IC    5,ARTHTAB(1)        PICK UP COMPUTE TYPE.                29210000
         N     5,=F'127'           REMOVE CHARACTER FLAG.               29440000
         SR    4,4                 AND -                                29670000
         IC    4,ARTHTAB+1(1)      RESULT TYPE.                         29900000
         N     4,=F'127'           REMOVE CHARACTER FLAG.               30130000
         LTR   0,0                 SEE IF A RESULT TYPE IS SPECIFIED.   30360000
         BZ    NOFORCE             BRANCH IF NOT.                       30590000
FORCE    LR    5,0                 PICK UP GIVEN TYPE.                  30820000
         LR    4,0                 MAKE COMPUTE TYPE THE SAME.          31050000
NOFORCE  C     5,OC4               SEE IF COMPUTE TYPE IS RESTRICTED.   31280000
         BNH   CRTYPE              BRANCH IF SO.                        31510000
         LR    5,3                 MOVE IN RIGHT TYPE, OTHERWISE.       31740000
         CR    5,2                 COMPARE TO LEFT TYPE.                31970000
         BNL   *+6                 BRANCH IF HIGHER OR EQUAL.           32200000
         LR    5,2                 OTHERWISE, MOVE IN LEFT TYPE.        32430000
         C     5,OC1               SEE IF CTYPE IS BOOLEAN.             32660000
         BH    CRTYPE              BRANCH IF NOT.                       32890000
         LA    5,2                 OTHERWISE, MAKE IT INTEGER.          33120000
CRTYPE   C     4,OC4               SEE IF RESULT TYPE IS RESTRICTED.    33350000
         BNH   *+6                 BRANCH IF SO.                        33580000
         LR    4,5                 OTHERWISE, IT'S CTYPE.               33810000
         LTR   2,2                 SEE IF THERE'S AN LH TYPE.           34040000
         BZ    GETRHCT             BRANCH IF NOT.                       34270000
         CR    2,5                 OTHERWISE, SEE IF CONVERSION IS NEED 34500000
         BE    GETRHCT             BRANCH IF NOT.                       34730000
         SLA   2,2                 OTHERWISE, GET CONVERSION CODE.      34960000
         AR    2,5                                                      35190000
         IC    2,FTCHTYP-5(2)      PICK UP FETCH CODE.                  35420000
GETRHCT  CR    3,5                 SEE IF RIGHT MUST BE CONVERTED.      35650000
         BE    ARTHEXT             BRANCH IF NOT.                       35880000
         SLA   3,2                 OTHERWISE, PICK UP FETCH CODE.       36110000
         AR    3,5                                                      36340000
         IC    3,FTCHTYP-5(3)      GOT IT.                              36570000
         SPACE                                                          36800000
*                                                                       37030000
*        NOW, PICK UP ROUTINE ADDRESS.                                  37260000
*                                                                       37490000
         SPACE                                                          37720000
ARTHEXT  S     1,OC2               REMOVE POSSIBLE EARLIER INCREMENT.   37950000
         O     1,OC2                                                    38180000
         AR    1,1                 MAKE OP DOUBLE WORD INDEX.           38410000
         C     5,OC3               SEE IF CTYPE IS FLOAT.               38640000
         BNE   *+8                 BRANCH IF NOT.                       38870000
         LA    1,4(1)              OTHERWISE, INCREMENT INDEX.          39100000
         LA    6,DYADTAB           PICK UP TABLE POINTER.               39330000
         LTR   2,2                 SEE IF OP IS DYADIC.                 39560000
         BNZ   *+8                 BRANCH IF SO.                        39790000
         LA    6,MONADTAB          OTHERWISE, PICK UP MONADIC TABLE.    40020000
         L     1,0(6,1)            PICK UP ROUTINE ADDRESS.             40250000
         LTR   1,1                 CHECK FOR ZERO.                      40480000
         BZ    ZEROADD             BRANCH IF SO.                        40710000
         IRETURN                   ,OTHERWISE, RETURN.                  40940000
         SPACE                                                          41170000
         SPACE                                                          41400000
*                                                                       41630000
*        IF WE FIND A ZERO ADDRESS, WE ASSUME THE OPERATOR HAS NOT YET  41860000
*        BEEN IMPLEMENTED AND GIVE A NONCE ERROR.                       42090000
*                                                                       42320000
         SPACE                                                          42550000
ZEROADD  LA    1,ESYNTAX                                                42780000
         ICALL ERROR                                                    43010000
         SPACE                                                          43240000
RNGEROR  LA    1,ERANGE                                                 43470000
         ICALL ERROR                                                    43700000
         EJECT                                                          43930000
*                                                                       44160000
*        CONSTANTS AND TABLES.                                          44390000
*                                                                       44620000
OC1      DC    F'1'                                                     44850000
OC2      DC    F'2'                                                     45080000
OC3      DC    F'3'                                                     45310000
OC4      DC    F'4'                                                     45540000
OC5      DC    F'5'                                                     45770000
OC11     DC    F'11'                                                    46000000
FTCHTYP  DC    FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'              46230000
*                                                                       46460000
         TITLE 'ARITHMETIC TYPE TABLE                         05/11/70' 46690000
         PRINT GEN                                                      46920000
         PRINT NOGEN                                                    47150000
*                                                                       47380000
BOOLR    EQU   1                                                        47610000
FIXR     EQU   2                                                        47840000
FLTR     EQU   3                                                        48070000
CHARR    EQU   4                                                        48300000
DONTCARE EQU   5                                                        48530000
NOCHAR   EQU   X'80'                                                    48760000
ZLAST    EQU   ZA-1                THIS MUST BE GT MAX OPERATOR SYMBOL. 48990000
*                                                                       49220000
*                                                                       49450000
         SPACE                                                          49680000
ARTHTAB  EQU   *                                                        49910000
         SPACE                                                          50140000
PLUS     ARTHTYPE DONTCARE+NOCHAR                                       50370000
MINUS    ARTHTYPE DONTCARE+NOCHAR                                       50600000
TIMES    ARTHTYPE DONTCARE+NOCHAR                                       50830000
DIV      ARTHTYPE FLTR+NOCHAR                                           51060000
STAR     ARTHTYPE FLTR+NOCHAR                                           51290000
MAX      ARTHTYPE DONTCARE+NOCHAR,FIXR,DONTCARE+NOCHAR                  51520000
MIN      ARTHTYPE DONTCARE+NOCHAR,FIXR,DONTCARE+NOCHAR                  51750000
MOD      ARTHTYPE DONTCARE+NOCHAR                                       51980000
AND      ARTHTYPE BOOLR+NOCHAR                                          52210000
OR       ARTHTYPE BOOLR+NOCHAR                                          52440000
LT       ARTHTYPE DONTCARE+NOCHAR,,,BOOLR                               52670000
LE       ARTHTYPE DONTCARE+NOCHAR,,,BOOLR                               52900000
EQ       ARTHTYPE DONTCARE,,,BOOLR                                      53130000
GE       ARTHTYPE DONTCARE+NOCHAR,,,BOOLR                               53360000
GT       ARTHTYPE DONTCARE+NOCHAR,,,BOOLR                               53590000
NE       ARTHTYPE DONTCARE,,,BOOLR                                      53820000
EPS      ARTHTYPE FIXR,BOOLR,DONTCARE                                   54050000
IOTA     ARTHTYPE FIXR,,DONTCARE                                        54280000
RHO      ARTHTYPE DONTCARE,FIXR,DONTCARE                                54510000
COMMA    ARTHTYPE DONTCARE                                              54740000
SHRIEK   ARTHTYPE FLTR+NOCHAR                                           54970000
REV      ARTHTYPE DONTCARE                                              55200000
BASE     ARTHTYPE DONTCARE+NOCHAR                                       55430000
REP      ARTHTYPE DONTCARE+NOCHAR                                       55660000
CIRCLE   ARTHTYPE FLTR+NOCHAR                                           55890000
QUERY    ARTHTYPE DONTCARE+NOCHAR,,FIXR+NOCHAR                          56120000
NOT      ARTHTYPE BOOLR+NOCHAR,,DONTCARE                                56350000
UARROW   ARTHTYPE DONTCARE                                              56580000
DARROW   ARTHTYPE DONTCARE                                              56810000
TRAN     ARTHTYPE DONTCARE                                              57040000
HIST     ARTHTYPE DONTCARE                                              57270000
LOG      ARTHTYPE FLTR+NOCHAR                                           57500000
NAND     ARTHTYPE BOOLR+NOCHAR                                          57730000
NOR      ARTHTYPE BOOLR+NOCHAR                                          57960000
COLREV   ARTHTYPE DONTCARE                                              58190000
UPGRADE  ARTHTYPE DONTCARE+NOCHAR,FIXR                                  58420000
DNGRADE  ARTHTYPE DONTCARE+NOCHAR,FIXR                                  58650000
DOMINO   ARTHTYPE FLTR+NOCHAR                                           58880000
LAST     ARTHTYPE DONTCARE                                              59110000
         TITLE 'DYADIC OPERATOR ROUTINE TABLE                 05/11/70' 59340000
         SPACE                                                          59570000
DYADTAB  DC    0F'0'                                                    59800000
         ENTRY DYADTAB                                                  60030000
RTNTAB   EQU   DYADTAB                                                  60260000
PLUS     DYADICOP EXADD,EXFAD                                           60490000
MINUS    DYADICOP EXSUB,EXFSB                                           60720000
TIMES    DYADICOP EXMPY,EXFMP                                           60950000
DIV      DYADICOP EXFDP                                                 61180000
STAR     DYADICOP EXEXP                                                 61410000
MAX      DYADICOP EXMAX,EXDMAX                                          61640000
MIN      DYADICOP EXMIN,EXDMIN                                          61870000
MOD      DYADICOP EXFRES,EXRES                                          62100000
AND      DYADICOP EXAND                                                 62330000
OR       DYADICOP EXOR                                                  62560000
LT       DYADICOP EXLSTH,EXDLSTH                                        62790000
LE       DYADICOP EXLSTHEQ,EXDLSTHE                                     63020000
EQ       DYADICOP EXEQUAL,EXDEQUAL                                      63250000
GE       DYADICOP EXGRTHEQ,EXDGRTHE                                     63480000
GT       DYADICOP EXGRTH,EXDGRTH                                        63710000
NE       DYADICOP EXNOTEQU,EXDNOTEQ                                     63940000
EPS      DYADICOP EXEPS                                                 64170000
IOTA     DYADICOP EXIOTA                                                64400000
RHO      DYADICOP EXRHO                                                 64630000
COMMA    DYADICOP EXCATEN                                               64860000
SHRIEK   DYADICOP EXBINOM                                               65090000
REV      DYADICOP EXDCIRSL                                              65320000
BASE     DYADICOP EXBASE                                                65550000
REP      DYADICOP EXREP                                                 65780000
CIRCLE   DYADICOP EXCIRCLE                                              66010000
QUERY    DYADICOP EXRANDOM                                              66240000
NOT      DYADICOP EXERROR                                               66470000
UARROW   DYADICOP EXTAKE                                                66700000
DARROW   DYADICOP EXLEAVE                                               66930000
TRAN     DYADICOP EXTRAN                                                67160000
HIST     DYADICOP EXCEINTF                                              67390000
LOG      DYADICOP EXDLOG                                                67620000
NAND     DYADICOP EXNAND                                                67850000
NOR      DYADICOP EXNOR                                                 68080000
*** FOLLOWING STATEMENT PRODUCES A HARMLESS ASSEMBLY ERROR ************ 68310000
COLREV   DYADICOP EXDCIRSL                                              68540000
UPGRADE  DYADICOP EXERROR                                               68770000
DNGRADE  DYADICOP EXERROR                                               69000000
DOMINO   DYADICOP EXDMATD                                               69230000
LAST     DYADICOP EXERROR                                               69460000
         TITLE 'MONADIC OPERATOR ROUTINE TABLE                05/11/70' 69690000
MONADTAB DC    0F'0'                                                    69920000
         ENTRY MONADTAB                                                 70150000
COMTBL   EQU   MONADTAB                                                 70380000
         SPACE                                                          70610000
PLUS     MONADOP EXMADD,EXMFAD                                          70840000
MINUS    MONADOP  EXMSUBT,EXMFSB                                        71070000
TIMES    MONADOP  EXMMPY,EXMFMP                                         71300000
DIV      MONADOP  EXMFDP                                                71530000
STAR     MONADOP  EXMEXP                                                71760000
MAX      MONADOP  EXCEIL,EXDCEIL                                        71990000
MIN      MONADOP  EXFLOOR,EXDFLOOR                                      72220000
MOD      MONADOP  EXABS,EXDABS                                          72450000
AND      MONADOP  EXERROR                                               72680000
OR       MONADOP  EXERROR                                               72910000
LT       MONADOP  EXERROR                                               73140000
LE       MONADOP  EXERROR                                               73370000
EQ       MONADOP  EXERROR                                               73600000
GE       MONADOP  EXERROR                                               73830000
GT       MONADOP  EXERROR                                               74060000
NE       MONADOP  EXERROR                                               74290000
ALPHA    MONADOP  EXERROR                                               74520000
EPS      MONADOP  EXERROR                                               74750000
IOTA     MONADOP  EXMIOTA                                               74980000
RHO      MONADOP  EXMRHO                                                75210000
OMEGA    MONADOP  EXERROR                                               75440000
COMMA    MONADOP  EXRAVEL                                               75670000
SHRIEK   MONADOP  EXFACT                                                75900000
REV      MONADOP  EXMREV                                                76130000
BASE     MONADOP  EXERROR                                               76360000
REP      MONADOP  EXERROR                                               76590000
CIRCLE   MONADOP  EXMCIRC                                               76820000
QUERY    MONADOP FRANDOM,DRANDOM                                        77050000
NOT      MONADOP  EXNOT                                                 77280000
UARROW   MONADOP  EXERROR                                               77510000
DARROW   MONADOP  EXERROR                                               77740000
TRAN     MONADOP  EXMTRAN                                               77970000
HIST     MONADOP  EXMHIST                                               78200000
LOG      MONADOP EXMLOG                                                 78430000
NAND     MONADOP EXERROR                                                78660000
NOR      MONADOP EXERROR                                                78890000
*** FOLLOWING STATEMENT PRODUCES A HARMLESS ASSEMBLY ERROR ************ 79120000
COLREV   MONADOP  EXMREV                                                79350000
UPGRADE  MONADOP  EXUPGRD                                               79580000
DNGRADE  MONADOP  EXDNGRD                                               79810000
DOMINO   MONADOP EXMMATD                                                80040000
LAST     MONADOP EXERROR                                                80270000
         PRINT NOGEN                                                    80500000
         TITLE 'OPERATOR TYPE TABLE                           05/11/70' 80730000
SCALAROP EQU   1                                                        80960000
ODDOP    EQU   2                                                        81190000
INDEXED  EQU   X'80'                                                    81420000
         SPACE                                                          81650000
         ENTRY OPTAG                                                    81880000
         ENTRY INDICTR                                                  82110000
INDICTR  EQU   *                                                        82340000
OPTAG    EQU   INDICTR                                                  82570000
PLUS     OPTYPE SCALAROP                                                82800000
MINUS    OPTYPE SCALAROP                                                83030000
TIMES    OPTYPE SCALAROP                                                83260000
DIV      OPTYPE SCALAROP                                                83490000
STAR     OPTYPE SCALAROP                                                83720000
MAX      OPTYPE SCALAROP                                                83950000
MIN      OPTYPE SCALAROP                                                84180000
MOD      OPTYPE SCALAROP                                                84410000
AND      OPTYPE SCALAROP                                                84640000
OR       OPTYPE SCALAROP                                                84870000
LT       OPTYPE SCALAROP                                                85100000
LE       OPTYPE SCALAROP                                                85330000
EQ       OPTYPE SCALAROP                                                85560000
GE       OPTYPE SCALAROP                                                85790000
GT       OPTYPE SCALAROP                                                86020000
NE       OPTYPE SCALAROP                                                86250000
EPS      OPTYPE ODDOP                                                   86480000
IOTA     OPTYPE ODDOP                                                   86710000
RHO      OPTYPE ODDOP                                                   86940000
COMMA    OPTYPE ODDOP,,,INDEXED                                         87170000
SHRIEK   OPTYPE SCALAROP                                                87400000
REV      OPTYPE ODDOP,,INDEXED                                          87630000
BASE     OPTYPE ODDOP                                                   87860000
REP      OPTYPE ODDOP                                                   88090000
CIRCLE   OPTYPE SCALAROP                                                88320000
QUERY    OPTYPE SCALAROP,ODDOP                                          88550000
NOT      OPTYPE SCALAROP,ODDOP                                          88780000
UARROW   OPTYPE ODDOP                                                   89010000
DARROW   OPTYPE ODDOP                                                   89240000
TRAN     OPTYPE ODDOP                                                   89470000
HIST     OPTYPE ODDOP                                                   89700000
LOG      OPTYPE SCALAROP                                                89930000
NAND     OPTYPE SCALAROP                                                90160000
NOR      OPTYPE SCALAROP                                                90390000
COLREV   OPTYPE ODDOP,,INDEXED                                          90620000
UPGRADE  OPTYPE ODDOP                                                   90850000
DNGRADE  OPTYPE ODDOP                                                   91080000
DOMINO   OPTYPE ODDOP                                                   91310000
LAST     OPTYPE  ODDOP                                                  91540000
         TITLE 'IDENTITY ELEMENTS                             05/11/70' 91770000
         ENTRY IDENTS                                                   92000000
         DC    0F'0'                                                    92230000
IDENTS   EQU   *-8*ZPLUS                                                92460000
         IDEL  PLUS,2,LA,0,0                                            92690000
         IDEL  MINUS,2,LA,0,0                                           92920000
         IDEL  TIMES,2,LA,0,1                                           93150000
         IDEL  DIV,2,LA,0,1                                             93380000
         IDEL  STAR,2,LA,0,1                                            93610000
         IDEL  MAX,3,LD,0,MINF                                          93840000
         IDEL  MIN,3,LD,0,PINF                                          94070000
         IDEL  MOD,2,LA,0,0                                             94300000
         IDEL  LT,1,LA,0,0                                              94530000
         IDEL  LE,1,L,0,BIT0                                            94760000
         IDEL  EQ,1,L,0,BIT0                                            94990000
         IDEL  GE,1,L,0,BIT0                                            95220000
         IDEL  GT,1,LA,0,0                                              95450000
         IDEL  NE,1,LA,0,0                                              95680000
         IDEL  AND,1,L,0,BIT0                                           95910000
         IDEL  OR,1,LA,0,0                                              96140000
         IDEL  SHRIEK,2,LA,0,1                                          96370000
         IDEL  NAND,0,LA,0,0       NO IDENTITY                          96600000
         IDEL  NOR,0,LA,0,0        NO IDENTITY                          96830000
         IDEL  LOG,0,LA,0,0        NO IDENTITY                          97060000
         IDEL  CIRCLE,0,LA,0,0     NO IDENTITY                          97290000
         ORG                                                            97520000
         DC    0D'0'                                                    97750000
MINF     DC    X'FFFFFFFFFFFFFFFF'                                      97980000
PINF     DC    X'7FFFFFFFFFFFFFFF'                                      98210000
BIT0     EQU   MINF                                                     98440000
         LTORG                                                          98670000
         END                                                            98900000
./  ADD    NAME=APLSASUP
ASUP   TITLE 'A P L S U P   M A C R O   D E F I N I T I O N S         ' 00010000
*              5734-XM6 COPYRIGHT IBM CORP. 1969,1970,1972              00020000
*              5736-XM6 COPYRIGHT IBM CORP. 1969,1970,1972              00030000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00040000
         MACRO                                                          00050000
&L       BAIL                                                           00060000
&L       L     2,=A(MVTPOST)       POST DAUGHTER                        00090000
         BALR  1,2                                                      00100000
         MEXIT                                                          00110000
         MEND                                                           00130000
         SPACE                                                          00140000
         MACRO                                                          00150000
&L       COMRG                                                          00160000
         MNOTE 7,'ENVIRONMENT CONFUSION.'                               00230000
         MEND                                                           00240000
         SPACE 1                                                        00250000
         MACRO                                                          00260000
&L       MODNOTE                                                        00270000
.*       FLAG DECISIONS DEPENDENT ON 4 WIRE MODEMS.                     00280000
&L       DC    0AL1(Q4WMDM)        DECISION POINT FOR 4 WIRE MODEM.     00290000
         MEND                                                           00300000
         SPACE 1                                                        00310000
         MACRO                                                          00320000
&L       SATSUB                                                         00330000
&L       BAL   LINK,SATPSUB        PURGE POSSIBLE INTERVAL EVENT.       00340000
         BAL   LINK,SATSUB         SET ATTENTION.                       00350000
         MEND                                                           00360000
         SPACE 1                                                        00370000
         MACRO                                                          00380000
         LOWCORE                                                        00390000
APLSUP   START 0                                                        00420000
APLLOW   EQU   *                                                        00470000
LOWCORE  DSECT                                                          00520000
         USING OURLOW,0                                                 00530000
OURLOW   DS    0D                                                       00540000
         DS    D                                                   C043 00550000
PINHEDD  DS    D                        DOUBLEWORD PINHED FOR PSW'S     00560000
         DS    2F                                                       00570000
         DS    2D                                                       00640000
PCOLDPSW DC    D'0'                                                C063 00660000
MCOLDPSW DC    D'0'                                                C063 00670000
IOOLDPSW DC    D'0'                                                C063 00680000
CSW      DC    D'0'                                                C063 00690000
CAW      DC    F'0'                                                C063 00700000
LOC76    DC    F'0'                                                C063 00710000
LOC80    DC    F'70000'                                                 00720000
SYSTOD   DC    F'0'                                                     00730000
EXNEWPSW DS    D                                                        00820000
SVNEWPSW DS    D                                                        00830000
PCNEWPSW DS    D                                                        00850000
MCNEWPSW DS    D                                                        00860000
IONEWPSW DC    0D'0',X'00040000',A(IOINT)                               00880000
         DS    256C                     DIAGNOSTIC SCANOUT AREA         00890000
         MEND                                                           00950000
         SPACE 1                                                        00960000
         MACRO                                                          00970000
         QZA7                                                           00980000
*                                                                       01120000
*        MVT WAIT.  WILL ONLY BE ISSUED ON THE DAUGHTER PRB.            01130000
*                                                                       01140000
QZA7     OI    SETHILO,SHLSTOPH    STOP SETHI/SETLO LOOP AT NEXT   3064 01150000
*                                  HIGH PRIORITY                   3064 01160000
*        WAIT  1,ECB=ECBFILLE      WAIT UNTIL POSTED BY ..              01170000
*                                  EXINT, MPXINT, OR SELINT.            01180000
         WAIT  1,ECB=ECBFILLE                                           01190000
         DC    0AL4(ALLON)    WAIT LEAVES US ENABLED.              3064 01200000
         MVI   ECBFILLE,0          RESET WAIT AND POST FLAGS       3064 01210000
         SPACE 2                                                   3064 01220000
         NI    SETHILO,NOT-SHLSTOPH WITHDRAW REQUEST TO STOP LOOP  3064 01230000
         TM    SETHILO,SHLACTIV    IS LOOP STILL ACTIVE?           3064 01240000
         BO    QZA0           IF SO, WE'RE DONE HERE               3064 01250000
         SPACE 1                                                   3064 01260000
*  APLSETHI/APLSETLO LOOP IS NO LONGER ACTIVE.                     3064 01270000
*  WE'LL ASSUME SUBTASK WAS LEFT AT HIGH PRIORITY, AS WE REQUESTED 3064 01280000
*                                                                  3064 01290000
         L     2,=A(BOUNSUB)       A CONVENIENT EXISTING ADCON     3064 01300000
         USING BOUNSUB,2           TELL ASSEMBLER                  3064 01310000
         LM    2,3,LOWLIM          TIME INTERVAL AT HIGH PRIORITY  3064 01320000
         DROP  2                                                   3064 01330000
         BAL   5,ENQIE        GET REALTIME, AND ENQUEUE INTERVAL   3064 01340000
         OI    SETHILO,SHLACTIV    INDICATE LOOP IS ACTIVE         3064 01350000
         B     QZA0           GO TO SCHEDULER                      3064 01360000
         MEND                                                           01370000
         SPACE 1                                                        01380000
         MACRO                                                          01390000
         QZE1                                                           01400000
QZE1     CLI   SELBUSY,1           TEST FOR SELECTOR CHANNEL BUSY       01420000
         BE    QZE3           SEE IF OS THINKS SELBUSY IS 1        DASD 01440000
         BL    QZE2                COMPLETELY FREE                      01500000
         MVI   SELBUSY,1           MAKE BUSY, APPENDAGE COULD NOT DO    01510000
         NI    SWITCHES,NOT-SELAPENT RESET THE APPENDAGE ENTRY SW  DASD 01600000
         L     1,=A(SELSTAR)       ADDRESSABILITY                  DASD 01610000
         USING SELSTAR,1                                           DASD 01620000
         MVI   SELCNT+1,0          CLEAR ERROR COUNTER.            DASD 01630000
         DROP  1                                                   DASD 01640000
*        EXCP  DSKIOB              EXCP ON DIFFERENT DCB                01650000
         EXCP  DSKIOB              EXCP ON DIFFERENT DCB                01660000
         B     QZA2                NOW BUSY, DON'T TRY TO INITIATE      01670000
         MEND                                                           01680000
         SPACE                                                          01690000
         MACRO                                                          01700000
         EXITPC                                                         01710000
SVTIME   EQU   SVILG               INTERPRETER GETS IT'S OWN TIME       01810000
SVEXITPC EQU   SVILG               DOS HANDLES EXIT PC                  01910000
         MEND                                                           01920000
         SPACE 1                                                        01930000
         MACRO                                                          01940000
         SELEXIT                                                        01950000
*                                                                       02030000
*        IF THE SELECTOR OPERATION DID NOT RESULT IN AN ERROR           02040000
*        OR IN ANOTHER OPERATION STARTING (IE SELBUSY = 0 OR 2),        02050000
*        AND THE DAUGHTER TASK IS WAITING AT QZA7, POST.                02060000
*                                                                       02070000
*        IMPORTANT ASSUMPTION.                                          02080000
*        THE PRIORITY OF THE DAUGHTER TASK IS ASSUMED                   02090000
*        NEVER TO EXCEED THAT OF THE MOTHER, SO THAT THE POST           02100000
*        BELOW WILL NEVER SET UP A TASK SWITCH.  A LATENT TASK SWITCH   02110000
*        MAY BE FATAL IF THE SELECTOR CHANNEL INTERRUPT CAME WHILE      02120000
*        EXECUTING IN THE APL SCHEDULER.                                02130000
         DROP  14                                                       02140000
         USING APLLOW,9                                                 02150000
SELEXIT  LR    9,14                14 GETS LOST BY POST.                02160000
         CLI   SELBUSY,1           TEST CURRENT SELECTOR STATUS.        02170000
         BE    SELEXITZ            BRANCH IF RESTARTING.                02180000
         BH    SELZPOST            BRANCH IF SELEXCP HAS BEEN CALLED.   02190000
* WHEN ABANDONING A COMMAND CHAIN, IT IS WISE TO INITIALIZE THE IOB.    02200000
* OTHERWISE, IOS MAY ATTEMPT ERROR RECOVERY AFTER HAVING DEQUEUED THE   02210000
* RQE OR SOMETHING.                                                     02220000
         MVC   DSKIOB+IOBFLAG1-IOBD(2),APLFLAGS                         02230000
         MVC   DSKIOB+IOBSENS0-IOBD(2),ZERO                             02240000
         MVC   DSKIOB+IOBFLAG3-IOBD(8),ZERO                             02250000
         MVI   DSKIOB+IOBECBCC-IOBD,X'7F'  NOTE CC ...                  02260000
SELZPOST BAIL                                                           02270000
*                                                                       02280000
*        RETURN TO IOS FROM CHANNEL END APPENDAGE.                      02290000
*                                                                       02300000
*        0(14) NORMAL RETURN - SPECIFIES SYSTEM ACTION.                 02310000
*              INCLUDING DEQUEUE AND ERROR RECOVERY.                    02320000
*        4(14) NOT COMPLETE (NO POST), BUT REQUEST ELEMENT IS           02330000
*              MADE AVAILABLE.                                          02340000
*        8(14) NOT COMPLETE (NO POST), RETRY CHAIN.                     02350000
*       12(14) NOT COMPLETE, REQUEST ELEMENT NOT MADE AVAILABLE.        02360000
*                                                                       02370000
*        THE RETURN HAS BEEN STORED IN THE SAVED R10.                   02380000
*        SEE SELEXCP.                                                   02390000
*                                                                       02400000
SELEXITZ RESET UGHSW,APPENDG                                       2217 02410000
SELUGH   MVC   CSW(8),MVTCSW       RESTORE REAL CSW.               2217 02420000
         LM    0,15,APLSAVE        RESTORE IOS' REGISTERS.              02430000
         SR    9,9                 GUARANTEE ZERO R9.                   02440000
         B     0(10,14)            RETURN TO IOS.                       02450000
         DROP  9                                                        02460000
         USING APLLOW,14                                                02470000
         SPACE                                                          02480000
         MEXIT                                                          02490000
         MEND                                                           02540000
         SPACE 1                                                        02550000
         MACRO                                                          02560000
&L       SVTOMX                                                         02570000
*        SETUP FOR BRANCH TO MULTIPLEX AND RETURN VIA R15               02580000
&L       STM   0,15,MPXSAVE        SAVE REGISTERS OVER MPX EXECUTION    02590000
         MVI   DELZFLG,2           FLAG FOR MPXEXIT                     02600000
         MEND                                                           02610000
         SPACE 1                                                        02620000
         MACRO                                                          02630000
         MPXEXIT                                                        02640000
*        RESOLVE MPX CALLER BY DELZFLG.. 0=MPXINT, 1=IEMPX, 2=INITMOP   02660000
MPXEXIT  CLI   DELZFLG,1                                                02670000
         BE    EXTIME              RETURN TO TIMER CODE            2217 02680000
         BH    MXRET1                                                   02690000
*        RETURN FROM MULTIPLEX INTERRUPT                                02700000
         RESET UGHSW,MPXIO                                         2217 02710000
         SPACE                                                          02850000
*                                                                       02860000
*        MVT MPXEXIT.                                                   02870000
*                                                                       02880000
* 1.                                                               C020 02890000
* 2.     MVTTCBP IS MXCVTTCB                                       C020 02900000
* 3.     GOTO MXZ1 IF RESCH=0                                           02910000
* 4.     RESCH IS 0                                                     02920000
* 5.     POST01 0,ECBFILLE,TCBFILLE                                     02930000
* 6. MXZ1:                                                         C020 02940000
* 7.     GOTO MXRET2 IF NOT OR/MXOLDPSW.(PP,WAIT).                 C020 02950000
* 8.     GOTO MXRET4 IF =/MVTTCBP                                  C020 02960000
* 9. MXRET3: CSW IS CAW IS 0                                       C020 02970000
*        GOTO  IOREJ                                               C020 02980000
*10. MXRET4: GOTO MXRET3 IF MXOLDPSW.(WAIT).                       C020 02990000
*11. MXRET2: GOTO MXOLDPSW                                         C020 03000000
         SPACE 3                                                   C020 03010000
*        RESTORE ALL VALUES SAVED AT MPXINT.                            03020000
*                                                                       03030000
         SPACE                                                          03040000
* 1.                                                                    03050000
* 2.                                                                    03060000
         SPACE 2                                                   C020 03070000
**-------------    SEE COMMENTS AT MPXINT   --------------------   C020 03080000
**       THE FOLLOWING CODE BACKS OFF DEBUGGING AID INSERTED AT    C020 03090000
**             MPXINT.                                             C020 03100000
         SPACE 2                                                   C020 03110000
         L     15,CVT    CVT POINTER                               C020 03120000
         L     3,CVTTCBP(15)  ADDRESS OF NEXT,CURRENT TCB POINTE   C020 03130000
         MVC   0(8,3),MXCVTTCB  RESTORE GLOBAL VALUE               C020 03140000
**-------  SEE NOTE ABOVE FOR DESCRIPTION OF PRECEEDING CODE       C020 03150000
         SPACE 2                                                   C020 03160000
* 3.                                                                    03170000
         CLI   RESCH,0             SEE IF APL BECAME FEASIBLE.          03180000
         BE    MXZ1                BRANCH IF NOT.                       03190000
* 4.                                                                    03200000
         MVI   RESCH,0                                                  03210000
* 5.                                                                    03220000
*        BAIL                                                      C020 03230000
         BAIL                                                           03240000
*                                                                       03250000
*        ENTER MVT DISPATCHER IF INTERRUPT CAME IN WAIT STATE.          03260000
*                                                                       03270000
*                                                                       03280000
* 6.                                                                    03290000
MXZ1     EQU   *                                                   C020 03300000
*                                                                       03310000
* 7.                                                                    03320000
         TM    MXOLDPSW+1,3        WAIT + PROBLEM STATE.                03330000
         BZ    MXRET2              BRANCH IF NEITHER.                   03340000
*                                                                       03350000
* 8.                                                                    03360000
         CLC   0(4,3),4(3)    TASK SWITCH REQUIRED ?               3572 03370000
         BE    MXRET4         NO, SAME GUY GETS CONTROL AGAIN      3572 03380000
*                                                                       03390000
* 9.                                                                    03400000
*                                                                  C020 03410000
*   A TASK SWITCH IS CALLED FOR, GO TO IOS AND LET IT HANDLE IT    C020 03420000
*                                                                  C020 03430000
MXRET3   XC    CSW(12),CSW    CLEAR CSW & CAW                      3572 03440000
*                          IOS SHOULD IGNORE THE 'MODIFIED'        3572 03450000
*                          INTERRUPT THAT WILL BE PASSED ON        3572 03460000
*                                                                  3572 03470000
         B     IOREJ          PASS IT DOWN THE LINE                3572 03480000
*                                                                  C020 03490000
* 10.                                                              C020 03520000
*                                                                  C020 03530000
MXRET4   TM    MXOLDPSW+1,2        IF IN WAIT STATE,  THEN         C020 03540000
         BO    MXRET3              .  LET OS HANDLE IT.            C020 03550000
*                                                                  C020 03560000
* 11.                                                              C020 03570000
*                                                                  C020 03580000
MXRET2   MVC   PINHEDD(8),MXOLDPSW RETURN TO INTERRUPTEE           C020 03600000
         LM    0,15,APLSAVE        RESTORE REGS                         03610000
         LPSW  PINHEDD                                                  03620000
MXRET1   LM    0,15,MPXSAVE        SVTOX (INITMOP) CALLED MPX CODE      03640000
         BR    LINK                RETURN TO SVC CODE                   03650000
         MEND                                                           03660000
         SPACE 1                                                        03670000
         MACRO                                                          03680000
         SELEXCP                                                        03690000
         SPACE                                                          04080000
*        IN MVT, SELEXCP HANDLES BOTH START AND RESTART.                04090000
*        IF DSKECB IS COMPLETE, THE CALL IS FROM THE SCHEDULER AND      04100000
*        AN EXCP MAY BE ISSUED.                                         04110000
*        IF DSKECB IS NOT COMPLETE, THE CALL IS FROM AN APPENDAGE ...   04120000
*        IF THE NEW REQUEST IS FOR THE DCB WHICH JUST ENDED, RETURN TO  04130000
*        IOS 8(14), TO REQUEST RE-EXCP.                                 04140000
*        IF THE NEW REQUEST IS FOR A DIFFERENT DCB, SETSELBUSY SO THAT  04150000
*        THE SCHEDULER WILL ISSUE AN EXCP, THEN RETURN 0(14).           04160000
*                                                                       04170000
*        NOTE..  EXCP WILL NORMALLY BE ISSUED ONLY ON THE DAUGHTER TCB. 04180000
*        THUS, SELECTOR CHANNEL IO GOES AT THE PRIORITY OF THE DAUGHTER 04190000
*        TASK.                                                          04200000
*                                                                       04210000
SELEXCP  L     2,=A(SELSTAR)       SETUP ADDRESSABILITY          K DASD 04220000
         USING SELSTAR,2                                         K DASD 04230000
         MVI   SEEKAD+1,EMPTYM     WIPEOUT OLD SEEKAD              DASD 04240000
         MVI   SELCNT+1,0          CLEAR ERROR COUNTER           K DASD 04250000
         NI    SWITCHES,NOT-SELAPENT RESET THE APPENDAGE ENTRY SW  DASD 04260000
SELEXCP2 ST    0,DSKIOB+IOBSTART-IOBD-1 CCW CHAIN(CAW)           K DASD 04270000
         ST    0,DSKIOB+IOBRESTR-IOBD RESTART CCW ADDRESS.              04280000
         L     2,CDCBASE           BASE REGISTER FOR DISK PARAMETERS    04290000
         USING CDCPARS,2                                                04300000
         LR    9,0                                                 5989 04310000
         L     9,0(9)              FIRST HALF OF FIRST CCW.             04320000
*                                  - WHICH MUST BE A SEEK.              04330000
         MVC   DSKIOB+IOBSEEK-IOBD+3(5),2(9)                            04340000
*                                  SEEK ADDRESS FOR STAND ALONE SEEK.   04350000
         LA    8,DCBL              LENGTH OF DCB.                       04360000
         LH    9,LOGAD             MVT VERSION, USED AS INDEX INTO DCB  04370000
*                                  TABLE.                               04380000
         MR    8,8                 DISPLACEMENT INTO DCB TABLE.         04390000
         EXTRN APLSDCBS                                                 04400000
         A     9,=A(APLSDCBS)      BASE OF DCB TABLE.                   04410000
         ST    9,DCBNEXT           DCB ADDRESS FOR NEXT EXCP.           04420000
*        RESET DCBIFLG AS DESCRIBED UNDER EXCP IN IOS PLM.              04430000
         CLI   49(9),X'40'                                              04440000
         BNH   *+8                                                      04450000
         NI    49(9),3                                                  04460000
         MVC   DSKIOB+IOBFLAG1-IOBD(2),APLFLAGS NORMAL IOBFLAG1 AND 2.  04470000
*                                                                       04480000
*        THE FOLLOWING FIELDS ARE RESET AS RECOMMENDED BY               04490000
*        C28-6550-5  S/360 OS SYSTEM PROGRAMMERS GUIDE.                 04500000
*                                                                       04510000
         MVC   DSKIOB+IOBSENS0-IOBD(2),ZERO  SENSE BYTES.               04520000
         MVC   DSKIOB+IOBFLAG3-IOBD(8),ZERO    IOBFLAG3 AND IOBCSW.     04530000
         MVI   DSKIOB+IOBECBCC-IOBD,0 ECB CONDITION CODE.               04540000
*        ECB COMPLETE BIT WILL BE ON IF FROM SCHEDULER.                 04550000
         TM    DSKECB,X'40'        SEE IF REQUEST WAS FROM SCHEDULER.   04560000
         MVI   DSKECB,0            RESET ECB FLAGS.                     04570000
         BO    SELST1              BRANCH IF FROM SCHEDULER.            04580000
*                                                                       04590000
*        MVT DOES NOT ALLOW ANY SVC'S FROM A CHANNEL END APPENDAGE.     04600000
*        IT WILL PROVIDE A RESTART ON THE SAME DCB.                     04610000
*                                                                       04620000
         CLC   DCBNEXT+1(3),DSKIOB+IOBDCBPT-IOBD  SEE IF SAME DCB.      04630000
DCBAMVC  MVC   DSKIOB+IOBDCBPT-IOBD(3),DCBNEXT+1 DCB ADDRESS TO IOB.    04640000
         MVI   SELBUSY,2           ASK SCHEDULER TO DO EXCP.            04650000
         BCR   7,LINK              EXIT IF DIFFERENT DCB.               04660000
         MVI   APLSAVE+3+4*10,8    OTHERWISE, SET 8(14) RETURN TO MVT.  04670000
         MVI   SELBUSY,1           TO INDICATE A RESTART.               04680000
         BR    LINK                                                     04690000
*        ISSUE EXCP.                                                    04700000
SELST1   EX    0,DCBAMVC           MOVE DCB ADDRESS TO IOB.             04710000
         MVI   SELBUSY,1           MARK I/O STARTED.                    04720000
         ST    15,S15FOSXC              SAVE R15 OVER EXCP         2543 04730000
*        EXCP  DSKIOB                                                   04740000
         EXCP  DSKIOB                                                   04750000
         L     15,S15FOSXC              RE-LOAD R15                2543 04760000
         BR    LINK                RETURN TO CALLER.                    04770000
         DROP  2                                                        04780000
         MEND                                                           04790000
         SPACE 1                                                        04800000
         MACRO                                                          04810000
         SELINT                                                         04820000
SELINT   EQU   *                                                        04940000
         CLI   CSW+5,PCICSW        PCI, PURE AND SIMPLE                 04960000
         BE    SELPCI                                                   04970000
         MEND                                                           04980000
         SPACE 1                                                        04990000
         MACRO                                                          05000000
         SELSTAR                                                        05010000
         SPACE                                                          05390000
*        MVT .. SELEXCP PERFORMS BOTH START AND RESTART.                05400000
SELSTAR  EQU   *                                                   C022 05410000
         B     SELEXCP2                                          K DASD 05420000
         MEND                                                           05430000
         SPACE 1                                                        05440000
         MACRO                                                          05450000
         SELTIME                                                        05460000
DRNOW1   L     10,=A(SELSTAR)                                           05690000
         B     SELEXIT-2           BALR LINK,10                         05700000
         MEND                                                           05710000
         SPACE                                                          05720000
         MACRO                                                          05730000
         SELACT                                                         05740000
SELACT   EQU   *                   DISK RETRY ROUTINES FOLLOW           05760000
         MEND                                                           06460000
         SPACE 1                                                        06470000
         MACRO                                                          06480000
&L       IEBRN &ADR,&INT                                                06490000
&L       DC    0F'0'          IEBASE SETTING                            06500000
         DC    AL1(IETBRN)          EVENT TYPE = BRN                    06510000
         DC    AL3(&ADR)      BRANCH TO &INT                            06520000
         DC    A(&INT)        AFTER &INT TIME HAS ELAPSED               06530000
         MEND                                                           06540000
         SPACE 1                                                        06550000
         MACRO                                                          06560000
&X       UGH   &C                                                       06570000
         GBLA  &UGHCTR                                                  06590000
         LCLC  &CC                                                  K01 06600000
&UGHCTR  SETA  &UGHCTR+1                                                06610000
         AIF   (T'&C  EQ 'O').UNCOND                                K01 06620000
&CC      SETC   '&C'(1,1)                                           K01 06630000
         AIF   ('&CC' EQ 'N').STRIP                                 K01 06640000
&CC      SETC  'N'.'&C'       NEGATE THE REQUESTED CONDITION        K01 06650000
         AGO   .GO                                                  K01 06660000
.STRIP   ANOP                                                       K01 06670000
&CC      SETC  '&C'(2,7)      STRIP THE N FROM THE REQUESTED COND   K01 06680000
.GO      ANOP                                                       K01 06690000
&X       B&CC  *+8                                                  K01 06700000
         AGO   .UGH                                                 K01 06710000
.UNCOND  ANOP                                                       K01 06720000
         AIF   (T'&X EQ 'O').UGH                                    K01 06730000
&X       DS    0H                                                   K01 06740000
.UGH     ANOP                                                       K01 06750000
UGH&UGHCTR BAL 14,UGH                                               K01 06760000
         MEND                                                           06770000
         SPACE 1                                                        06780000
         MACRO                                                          06790000
&L       IETGEN &A                                                      06800000
.*       CREATE IETAB ENTRIES                                           06810000
&L       DCY   IE&A                                                     06820000
IET&A    EQU   *-2-IETAB           CODE FOR IEBASE BYTE ZERO            06830000
         MEND                                                           06840000
*                                                                       06850000
         SPACE 1                                                        06860000
         MACRO                                                          06870000
&L       TUSSIG  &STATUS,&SIG                                           06880000
         GBLA  &TUSSC                                                   06890000
         GBLB  &NOLAB                                                   06900000
         GBLC  &TUSSG                                                   06910000
.*       CREATE AN ENTRY IN STATUS SENSE TO SIGNAL MAP                  06920000
         AIF   (&NOLAB).SS1                                             06930000
         AIF   (T'&L EQ 'O').SS2                                        06940000
         TUSSLC &L               DEFINE LENGTH                          06950000
.SS2     ORG   &TUSSG+&TUSSC                                            06960000
&L       DC    AL1(&STATUS)      SEARCH ARGUMENT                        06970000
         ORG   *-1+TUSSL                                                06980000
         DC    AL1(&SIG)         RESULT OF SEARCH                       06990000
.SS1     ANOP                                                           07000000
&TUSSC   SETA  &TUSSC+1                                                 07010000
         MEND                                                           07020000
         SPACE 1                                                        07030000
         MACRO                                                          07040000
&L       SELSIG &SENSE,&DRAD                                            07050000
.*       DISK SENSE TO ACTION MAP                                       07060000
&L       TUSSIG &SENSE,&DRAD-SELACT                                     07070000
         MEND                                                           07080000
         SPACE 1                                                        07090000
         MACRO                                                          07100000
&L       TUSGEN                                                         07110000
         GBLA  &TUSSC                                                   07120000
         GBLB  &NOLAB                                                   07140000
         GBLC  &TUSSG                                                   07150000
&TUSSC   SETA  0                                                        07160000
         AIF   (T'&L EQ 'O').TUS1                                       07170000
.*       GENUINE CALL OF TUSGEN                                         07180000
&L       EQU   *                                                        07190000
&TUSSG   SETC  '&L'                                                     07200000
&NOLAB   SETB  0                                                        07210000
         AGO   .TUS2                                                    07220000
.TUS1    ANOP                                                           07230000
.*       LENGTH COMPUTATION CALL OF TUSGEN                              07240000
&NOLAB   SETB  1                                                        07250000
.TUS2    ANOP                                                           07260000
.*       CALLS OF TUSSIG FOLLOW  IIIIIIIIIIIIIIIIIIIIIIIIIIII           07270000
*        SENSE BYTES FOR 1050, 2741, AND TS41                           07280000
SE1050   TUSSIG INTREQ+COMREJ,SGINTR                                    07290000
         TUSSIG OVERRUN+DATAC+EQUIPC+LOSTDATA,SGMIN                     07300000
         TUSSIG TIMEOUT,SGMIN                                           07310000
*        SENSE BYTES FOR AMBIGUOUS DEVICE                               07320000
SEAMBIG  TUSSIG INTREQ+COMREJ,SGINTR                                    07330000
         TUSSIG OVERRUN+DATAC+EQUIPC+LOSTDATA,SGMIN                     07340000
         TUSSIG TIMEOUT,SGTIME                                          07350000
SE1052   TUSSIG EQUIPC+DATAC+INTREQ,SGMIN                               07360000
*        TABLE FOR UE1050 USE                                           07480000
UECCWI   TUSSIG 2,SGMIN       READ                                      07490000
         TUSSIG X'0A',SGMIN   INHIBIT                                   07500000
         TUSSIG 1,255         WRITE, SIO DIAG1                          07510000
         TUSSIG ENABLE,SGTIME HIO                                       07520000
         TUSSIG 6,SGTIME      HIO ON PREPCCW                            07530000
.*       CALLS OF TUSSIG PRECEDE   IIIIIIIIIIIIIIIIIIIIIIIII            07540000
         AIF   (NOT &NOLAB).TUS3                                        07550000
.*       LENGTH COMPUTATION CALL                                        07560000
TUSSL    EQU   &TUSSC            LENGTH OF DSECT                        07570000
         MEXIT                                                          07580000
.TUS3    TUSSLC                                                         07590000
         MEND                                                           07600000
         SPACE 1                                                        07610000
         MACRO                                                          07620000
         TUSSLC &L                                                      07630000
         GBLA  &TUSLCM,&TUSSC                                           07640000
         GBLC  &TUSLCP                                                  07650000
         LCLC  &LC1                                                     07660000
.*   COMPUTE LENGTH OF PREVIOUS TABLE                                   07670000
         AIF   ('&TUSLCP' EQ '&LC1').SS1                                07680000
&LC1     SETC  '&TUSLCP.X'                                              07690000
&LC1     EQU   &TUSSC-&TUSLCM                                           07700000
.SS1     ANOP                                                           07710000
&TUSLCP  SETC  '&L'                                                     07720000
&TUSLCM  SETA  &TUSSC                                                   07730000
         MEND                                                           07740000
         SPACE 1                                                        07750000
         MACRO                                                          07760000
         SSA   &STE,&SIG,&ACT                                           07770000
.*       MAKE AN ENTRY IN  STATE,SIGNAL  TO ACTION MAP                  07780000
         ORG   MXSSAG+&STE+&SIG                                         07790000
         DC    AL1((&ACT-ACTBASE)/2)                                    07800000
         DC    0AL1(ACTBASE+511-&ACT)                                   07810000
*        IF PRECEDING ASSEMBLES IN ERROR,  ACTION IS NOT WITHIN THE     07820000
*        REQUIRED 512 BYTES OF ACTBASE, AND THE TABLE IS BLOWN.         07830000
         MEND                                                           07840000
         SPACE 1                                                        07850000
         MACRO                                                          07860000
         MPDVX &NUM                                                     07870000
         LCLC  &A,&B                                                    07890000
DX&NUM   DC    AL1(SE&NUM.X)                                            07900000
Q&NUM    EQU   DX&NUM-PERDEVXG                                          07910000
         AIF   ('&NUM' EQ 'TS41').A1                                    07920000
         MPDVY &NUM                                                     07930000
         AGO   .A2                                                      07940000
.A1      MPDVY 2741,NUM2=TS41                                           07950000
.A2      AIF   ('&NUM' EQ 'AMBIG').A3                                   07970000
&A       SETC  'TYO&NUM'                                                07980000
&B       SETC  'TYI&NUM'                                                07990000
         EXTRN &A,&B                                                    08000000
         DC    A(&A,&B)      TRANSLATE TABLES FOR &NUM                  08010000
         MEXIT                                                          08020000
.A3      ANOP                                                           08030000
         DC    2A(EMPT3)   AMBIG TRANSLATE TABLE=PROGRAM CHECK     C020 08040000
         MEXIT                                                          08050000
         MEND                                                           08080000
         SPACE 1                                                        08090000
         MACRO                                                          08100000
         MPDVY &NUM,&NUM2=2741                                          08110000
         DC    AL3(SE&NUM.)      ORIGIN OF SENSE BYTE TABLE             08120000
         DC    A(UE&NUM.)          UNIT EXCEPTION ROUTINE               08130000
         AIF   ('&NUM' EQ '2741').A1                                    08140000
         DC    A(MXR&NUM.)         READ CCW SETUP ROUTINE               08150000
         MEXIT                                                          08160000
.A1      DC    AL1(RST&NUM2.-INPOLL)   ADDRESS OF RESEND TEXT           08170000
         DC    AL3(MXR2741)                                             08180000
         MEND                                                           08190000
         SPACE 1                                                        08200000
         MACRO                                                          08210000
&L       PHGEN &INF,&DIV,&NDX                                           08220000
.*       GENERATE HISTOGRAMS TABLE                                      08250000
.*             CHANGE COMMENTS AT HISTCOMP WHEN CHANGING HISTOGRAMS     08260000
.*       &INF IS MAXIMUM VALUE AND MUST BE LESS THAN X'FFFFFF'          08270000
.*       &DIV IS NUMBER OF ENTRIES IN HISTOGRAM                         08280000
.*       &NDX IS NUMBER FOR USE WITH ZHIST OPERATOR                     08290000
PERH&L   DC    A(&DIV-1,&INF/(&DIV-1),HTAB&L)  PERHIST                  08300000
HDIR     CSECT ,                   HISTOGRAM DIRECTORY                  08310000
         ORG   HBASE+8*&NDX                                             08320000
         DC    A(HTAB&L,4+(&DIV+1)/2*4)  ADDRESS,LENGTH                 08330000
HTAB     CSECT ,                   HISTOGRAM TABLES                     08340000
HTAB&L   DC    ((&DIV+3)/2)F'0'    SPACE FOR THIS HIST TABLE            08350000
&SYSECT  CSECT                                                          08360000
         MEND                                                           08380000
         SPACE 1                                                        08390000
         MACRO                                                          08400000
         DEREL                                                          08410000
.*       MACRO TO FIX UP RELATIVE Y CONSTANTS                           08430000
         AR    10,14                                                    08450000
         MEND                                                           08470000
         SPACE 1                                                        08480000
         MACRO                                                          08490000
&L       DCY   &A                                                       08500000
&L       DC    Y(&A-APLLOW)        APLSUP LIVES IN HIGH CORE            08560000
         MEND                                                           08570000
         SPACE 1                                                        08580000
         MACRO                                                          08590000
         SVINT   &X                                                     08600000
         AIF   ('&X' EQ 'SA').SVCZ1                                     08620000
         AGO   .SVINT                                                   08630000
.SVCZ1   AGO   .SVCZ                                                    08640000
.SVINT   ANOP                                                           08650000
.*       GENERATE SVC INT HANDLER FOR EITHER SYSTEM                     08660000
.*       STATEMENTS NEEDED ONLY FOR EXECUTED SVCS ARE FLAGED        EX  08670000
*                                                                       08690000
*        APL SUPERVISOR CALL INTERFACE                                  08700000
*                                                                       08710000
*        ALL SVC REQUESTS IN THE INTERPRETER ARE MADE VIA THE SVCC      08720000
*        MACRO.  THIS MACRO MAPS ALL APL SVC'S TO A SINGLE SVC CODE,    08730000
*        FOLLOWED BY A HALFWORD YYCODE.  THE FOLLOWING ROUTINE MAPS     08740000
*        THE YYCODE INTO THE SVC OLD PSW, AND ADJUSTS THE INSTRUCTION   08750000
*        LENGTH CODE.  IN THE CASE OF AN EXECUTED SVCC, THE YYCODE      08760000
*        IS IN A HALFWORD FOLLOWING THE SVC INSTRUCTION.                08770000
*                                                                       08780000
*        THE ACTUAL SVC CODE IS DESIGNATED IN THE APL CONFIGURATION,    08790000
*        AND IS RESOLVED BY THE LINKAGE EDITOR AS THE DIFFERENCE        08800000
*        BETWEEN THE EXTERNAL SYMBOLS "APLMAP" AND "APLSVC".            08810000
*                                                                       08820000
         AGO   .OSSVC                                                   08830000
.OSSVC   ANOP                                                           09270000
.*       OS APL SVC ENTRY                                               09280000
*        APL SVC'S ARE PASSED TO US FROM THE TYPE-I SVC ROUTINES        09290000
*                                                                       09300000
SVINT    BALR  MR,0                FOR ADDRESSING CURRENTM              09310000
         USING *,MR                                                     09320000
         L     MR,CURRENTM         INTERPRETER MAY HAVE LOST MR         09330000
         DROP  MR                                                       09340000
         STM   0,15,REGSV-M(MR)                                         09350000
         BALR  2,0                 TEMPORARY BASE REGISTER              09360000
         USING SVINTR1,2                                                09370000
SVINTR1  EQU   *                                                        09380000
.SVC3    AGO   .SVCD                                                    09390000
.SVCD    L     1,SVOLDPSW+4        ADDRESS HALF OF OLD PSW              09430000
         LH    3,0(0,1)            PICK UP YYCODE (JUNK IF EXEC SVC)    09440000
         AH    1,=H'2'             INCREMENT IAR                        09450000
         BM    SVINTR2             BRANCH IF EXECUTED SVC           EX  09460000
*                                                                       09470000
*        MAPPED SVC - INCREMENT IAR BEYOND YYCODE                       09480000
         ST    1,SVOLDPSW+4        UPDATED IAR                          09490000
         XI    SVOLDPSW+4,X'C0'    UPDATE ILC TO INDICATE 4 BYTE INSTR  09500000
         AGO   .SVCJ                                                    09510000
.SVCJ    ANOP                                                           09570000
SVINTR4  LM    MR,14,SVBASE        STANDARD ADDRESSABILITY FOR MPX/SVC  09580000
         USING MPXSAVE,MR                                               09590000
         USING APLLOW,14                                                09600000
         DROP  2                                                        09610000
SVINTR5  STC   3,SVOLDPSW+3        REPLACE INTR CODE WITH YYCODE        09620000
         SET   UGHSW,SVC                                           2217 09640000
*                                                                       09650000
*        VALIDATE YYCODE AND ENTER PROPER SVC ROUTINE.                  09660000
         CLI   SVOLDPSW+3,SVMAX        VALIDATE SVC CODE                09670000
         BH    SVILG               ILLEGAL SVC                          09680000
         LH    2,SVOLDPSW+2        PICK UP SVC YYCODE                   09690000
         AR    2,2                                                      09700000
         LH    10,SVCTAB(2)                                             09710000
*        DEREL ,                   DERELATIVIZE                         09720000
         DEREL  ,                  DERELATIVIZE                         09730000
         BR    10                                                       09740000
         DROP  MR                                                       09750000
         DROP  14                                                       09770000
*                                                                   EX  09790000
*        EXECUTED MAPPED SVC, LOCATE SVC TO PICK UP YYCODE          EX  09800000
         USING SVINTR1,2                                            EX  09810000
SVINTR2  AH    1,=H'-6'            POINT TO EXECUTE INSTRUCTION     EX  09820000
         MVN   SVINTEX+1(1),1(1)   INDEX REGISTER  $$$$$ PROG MODIF EX  09830000
         MVC   SVINTEX+2(2),2(1)   BASE AND DISPL  $$$$$ PROG MODIF EX  09840000
         DROP  2                                                    EX  09850000
         LM    0,3,0(MR)           RESTORE USER REGISTERS           EX  09860000
SVINTEX  LA    4,*-*(*-*,*-*)      FAKE EX  $$$$$ PROG MODIFIED $$$ EX  09870000
         LH    3,2(0,4)            PICK UP YYCODE                   EX  09880000
         AGO   .SVCG                                                    09890000
.SVCG    ANOP                                                       EX  09940000
         BALR  2,0                                                EX    09950000
         USING *,2                                                EX    09960000
         LM    MR,14,SVBASE        STANDARD ADDR FOR MPX/SVC        EX  09970000
         USING APLLOW,14                                            EX  09980000
         DROP  2                                                    EX  09990000
         B     SVINTR5             GO PLANT YYCODE IN SVOLDPSW      EX  10000000
         DROP  14                                                   EX  10010000
         AGO   .SVCZ                                                    10020000
.SVCZ    MEND                                                           10130000
         SPACE 1                                                        10140000
         MACRO                                                          10150000
         SVEXIT                                                         10160000
*                                                                       10180000
*        RETURN TO INTERPRETER FROM SVCC CALL                           10190000
SVEXIT   L     1,CURRENTM                                               10200000
         RESET UGHSW,SVC                                           2217 10210000
         MVC   PINHEDD(8),SVOLDPSW                                      10260000
         LM    0,15,REGSV-M(1)                                          10270000
         LPSW  PINHEDD                                                  10280000
         MEND                                                           10290000
         SPACE 1                                                        10300000
         MACRO                                                          10310000
         SVRAPEIT                                                       10320000
*                                                                       10340000
*        VIOLATE MACRO  --  REQUEST ANOMALOUS PROTECT EXCEPTION         10350000
*                                                                       10360000
SVRAPE   SSM   ALLOFF              INHIBIT SEL CHAN INT WITH MR WRONG   10370000
         L     2,SVOLDPSW+4        POINT TO INSTRUCTION TO EXECUTE      10380000
         MVC   PINHEDD(6),0(2)     MOVE TO PREFIX STORAGE               10390000
         LM    0,15,REGSV          ALL 16 REGISTERS.                    10400000
         EX    0,PINHEDD                                                10410000
         BALR  14,0                TEMPORARY ADDRESSABILITY             10430000
         USING *,14                                                     10440000
SVRAPE2  SH    14,SVRPCON          ADJUST BACK TO APLLOW                10450000
         USING APLLOW,14                                                10460000
         LM    MR,13,SVBASE        RESTORE BASE REGISTERS           K10 10490000
         STM   0,MR-1,REGSV   GIVE SAVED REGS VALUE SET BY EXECUTED K10 10500000
         ST    15,REGSV+60         INST (EXCEPT FOR REGS HE HAS         10560000
*                                  NO BUSINESS ALTERING)                10570000
         L     2,SVOLDPSW+4        RESTORE OLD PSW TO R2                10580000
         SR    1,1                 ADD INSTRUCTION LENGTH TO R2         10590000
         IC    1,0(0,2)            DETERMINE FROM 1ST 2 BITS OF OP      10600000
         SRL   1,6                                                      10610000
         IC    1,SVRPTAB(1)                                             10620000
         AR    2,1                 NEXT INSTRUCTION ADDRESS             10630000
         ST    2,SVOLDPSW+4                                             10640000
         MEND                                                           10650000
         SPACE 1                                                        10660000
         MACRO                                                          10670000
         QZACT &SETPAN                                             2219 10680000
         AIF   ('&SETPAN' EQ 'SETPAN').A2S                         2219 10720000
         AGO   .A2OS                                                    10730000
.A2OS    ANOP                                                      2219 10770000
*        TTIMER                                                         10780000
         TTIMER                                                         10790000
         AGO   .A2C                                                2219 10800000
.A2S     ANOP                                                      2219 10810000
*                                                                  2219 10820000
*        TTIMERS ,            GET CPU TIME REMAINING               2219 10830000
         TTIMERS ,            GET CPU TIME REMAINING               2219 10840000
.A2C     ANOP                                                      2219 10850000
         S     0,TTERM        THIS IS CPU TIME USED                2219 10860000
         LPR   0,0            COMPENSATE FOR BACKWARDS SUBTRACT    2219 10880000
         SRL   0,7                 OS TU TO APL TU.                     10890000
         MEND                                                           10900000
         SPACE 1                                                        10910000
         MACRO                                                          10920000
         QAACT                                                          10930000
         LCLC  &L                                                  2219 10950000
*STYIZ2  TTIMER ,                  SAMPLE THE CPU TIMER            2219 11080000
STYIZ2   TTIMER ,                  SAMPLE THE CPU TIMER            2219 11090000
         CL    0,=A(PANICINT*256) IS REMAINING INTERVAL ENOUGH?    2219 11100000
         BH    STYIZ3         IF YES, DON'T RE-ISSUE THE STIMER    2219 11110000
*                                                                  2219 11120000
*  CPU TIMER IS GETTING LOW,   RE-ISSUE IT                         2219 11130000
*                                                                  2219 11140000
         LA    1,=A(12*60*60*300*128) 12 HOURS IN OS TIMER UNITS   2219 11150000
         MVC   TIMEHI,0(1)    INITIALIZE TIMEHI FOR APLSETHI/LO    3064 11160000
*  NOTE: THE ABOVE INSTRUCTION MAY CAUSE A DISTORTION              2219 11170000
*        IN THE SHARING OF CPU TIME BETWEEN APL AND                2219 11180000
*        BACKGROUND.  EVERY "HALFDAY", APL MAY RUN AT              2219 11190000
*        HIGH PRIORITY FOR AN ADDITIONAL "PANICINT"                2219 11200000
*        TIME INTERVAL.                                            2219 11210000
*        STIMER TASK,TUINTVL=(1)   SET CPU TIMER FOR HALFDAY       2219 11220000
         STIMER TASK,TUINTVL=(1)   SET CPU TIMER FOR HALFDAY       2219 11230000
         B     STYIZ2              LOOK AT THE TIMER VALUE AGAIN.  2219 11240000
         SPACE 1                                                   2219 11250000
&L       SETC  'STYIZ3'                                            2219 11260000
&L       ST    0,TTERM        FOR USE AT QUANTUM END (AND SETPAN)  2219 11280000
         MEND                                                           11290000
         SPACE 1                                                        11300000
         MACRO                                                          11310000
         SETPAN                                                         11320000
SETPAN   L     2,RBFILLE      EXAMINE DAUGHTER RESUME PSW          2219 11450000
         TM    RBOPSW+1(2),1  DON'T GIVE  APLSUP A PROGRAM CHECK   2219 11460000
         BZ    SETBELL0       RE-ENQUEUE SETPAN                    2219 11470000
*                             MAKE CERTAIN THAT INTRP HAS HAD      2219 11480000
*        QZACT SETPAN         SUFFICIENT TIME TO RESPOND TO QUEND  2219 11500000
         QZACT SETPAN                                              2219 11510000
         C     0,PANLIM+4          CHECK CPU TIME FOR THIS QUANTUM      11520000
         BL    SETBELL1       GIVE INTRP MORE TIME                 2219 11540000
*                                                                  5997 11550000
*  BECAUSE A PROGRAM CHECK WHILE IN THE PIE ROUTINE CAUSES AN ABEN 5997 11560000
*                                                                  5997 11570000
         L     1,TCBFILLE     INTERPRETER'S TCB                    5997 11580000
         L     1,TCBPIE(,1)   INTERPRETER'S PIE                    5997 11590000
         TM    0(1),X'80'     IS PIE ACTIVE?                       5997 11600000
         BO    SETBELL0       YES,TRY AGAIN LATER                  5997 11610000
*                                                                  5997 11620000
         OI    RBOPSW+5(2),EMPTYM  FORCIBLY TERMINATE QUANTUM      2219 11630000
         B     EXTIM2                                              2219 11740000
         MEND                                                           11750000
         SPACE 1                                                        11760000
         MACRO                                                          11770000
         SETHILO                                                        11780000
*        SET BACKGROUND TO HIGH PRIORITY                                11800000
         USING APLSETLO,PTR                                             11810000
         ENTRY APLSETLO            FOR CONFIG.                          11820000
*                                                                       11840000
*        *** ADAPTIVE ALGORITHM FOR PRIORITY ALLOCATION. ***            11850000
*                                                                       11860000
*        THIS ALGORITHM IS SUBJECT TO THE FAILINGS OF ALL ADAPTIVE      11870000
*        ALGORITHMS, INCLUDING INSTABILITY.  HOWEVER, WE CAN MAKE THE   11880000
*        FOLLOWING TWO ASSERTIONS ..                                    11890000
*        1.    A. THIS IS NOT A FEEDBACK ALGORITHM.                     11900000
*              B.  THE RESPONSE TIME FAR EXCEEDS THE WAVE LENGTH        11910000
*              OF THE INPUT.                                            11920000
*        2.    SINCE THE ALGORITHM DOES NOT DISPATCH RESOURCES, BUT     11930000
*              MODIFIES PRIORITIES FOR RESOURCES, INSTABILITY WON'T     11940000
*              HURT.  AT WORST, UNDER HEAVY COMPETITION FROM OTHER      11950000
*              PARTITIONS OR TASKS,  POOR RESPONSE MAY RESULT WHEN      11960000
*              THE NUMBER OF USERS SIGNED ON IS SMALL BUT INCREASING    11970000
*              RAPIDLY.  THE 1 TO 1 MINIMUM RATIO SHOULD MINIMIZE THIS  11980000
*              PROBLEM IF MAXQUAN IS RELATIVELY SMALL.                  11990000
*                                                                       12000000
*        HILIM..  IS THE DURATION OF APL LOW PRIORITY.                  12010000
*        ASSUMPTION.. HILIM DURATION IS MAXQUAN.                        12020000
*        LOWLIM..  IS THE DURATION OF APL HIGH PRIORITY.                12030000
*        POSO ..  IS +/SIGNED ON APL.                                   12040000
*        MAXQUAN ..  IS THE NORMAL CPU QUANTUM FOR APL USERS.           12050000
*                                                                       12060000
*                                                                       12070000
*        ALGORITHM..                                                    12080000
* 1.     T IS (FLOOR POSO DIV PPERQ)-PPERN                              12090000
* 2.     GOTO ASL1 IF T LT 0                                            12100000
* 3.     LOWTIME IS MAXQUAN                                             12110000
* 4.     HIGHTIME IS MAXQUAN TIMES T+1                                  12120000
* 5. GOTO ASL2                                                          12130000
* 6. ASL1..    HIGHTIME IS MAXQUAN                                      12140000
* 7.     LOWTIME IS MAXQUAN TIMES -T                                    12150000
* 8. ASL2..                                                             12160000
*                                                                       12170000
APLSETLO LM    2,3,POSO       +/SIGNEDON                           3064 12180000
.*  R3  IS LOADED WITH A SMALL POSITIVE NUMBER, SO THAT THE DIVIDE 3064 12190000
.*    WILL GIVE CONSISTENT RESULTS.  IDEALLY, R3 SHOULD BE 0, BUT  3064 12200000
.*    SLIGHT ERROR INTRODUCED SHOULD NOT BE SIGNIFICANT, AND IT    3064 12210000
.*    TAKES LESS CORE.                                             3064 12220000
         D     2,PPERQ             SCALED FLOOR POSO DIV PPERQ          12230000
         S     3,PPERN             T                                    12240000
         SRA   3,16                UNSCALED                             12250000
         L     2,QUANLIM+4         MAXQUAN                              12260000
         BM    ASL1                                                     12270000
         ST    2,LOWTIME           MAXQUAN                              12280000
         LA    3,1(3)              T+1                                  12290000
         MR    2,2                 MAXQUAN TIMES T+1                    12300000
         ST    3,HIGHTIME                                               12310000
         B     ASL2                                                     12320000
ASL1     ST    2,HIGHTIME          MAXQUAN                              12330000
         LPR   3,3                                                      12340000
         MR    2,2                 MAXQUAN TIMES -T                     12350000
         ST    3,LOWTIME                                                12360000
ASL2     EQU   *                                                        12370000
*                                                                  3064 12390000
*        TTIMERS ,           SAMPLE OUR CPU TIMER                  3064 12400000
         TTIMERS ,           SAMPLE OUR CPU TIMER                  3064 12410000
*                                                                  3064 12420000
         LCR   1,0            -CURRENT TIMER VALUE                 3064 12430000
         AL    1,TIMEHI      TIMER VALUE WHEN WE CHAPPED UP        3064 12440000
         TM    SETHILO,SHLSTOPH    IS A REQUEST TO STOP CYCLE PENDI3064 12450000
.*              IF THERE IS, WE NEED NOT INSIST ON OUR FULL        3064 12460000
.*              SHARE OF HIGH PRIORITY TIME.                       3064 12470000
         BNZ   ASL2S          YES                                  3064 12480000
         SRL   1,7           OS TO APL TIMER UNITS                 3064 12490000
         LM    2,3,LOWLIM    INTERVAL EVENT FOR TIMING HIGH APL    3064 12500000
         SR    3,1           SUBTRACT WHAT WE ALREADY USED, AND    3064 12510000
         BP    ASLZ2         RE-ENQUEUE THE REMAINING TIME  IFF    3064 12520000
*   WE DID NOT GET ENOUGH TIME AT HIGH PRIORITY                    3064 12530000
         SLL   1,7            APL  TO  OS  TIMER UNITS             3064 12540000
*                                                                  3064 12550000
*        LOWER PRIORITY OF DAUGHTER TASK TO ZERO.                       12560000
*                                                                  3064 12570000
*   CREATE HISTOGRAM FOR CPU TIME AT HIGH PRIORITY                 3064 12580000
*                                                                  3064 12590000
ASL2S    ST    0,TIMEHI             CPU TIME AT SWITCH TO LOW PR   3064 12600000
*        NOTE:  REG1 WAS SET UP BY  TTIMERS  ABOVE.                3064 12610000
*        LR    HISTVAL,1                                           3064 12620000
         LA    PHR,PERHHCPU   HIGH PRIORITY HISTOGRAM              3064 12630000
         BAL   LINK,HISTCOMP                                       3064 12640000
         LH    0,CHAPLOW      DISPATCHING PRIORITY  DECREMENT      3586 12650000
         LM    2,3,HILIM           DSETLOW EVENT                        12720000
         B     ASL3                                                     12730000
*                                                                       12740000
*        SET BACKGROUND TO LOW PRIOITY                                  12750000
         USING APLSETHI,PTR                                             12760000
*        RAISE DAUGHTER TASK TO LIMIT PRIORITY.                         12840000
*APLSETHI TTIMERS ,          SAMPLE OUR CPU TIMER                  3064 12850000
APLSETHI TTIMERS  ,          SAMPLE OUR CPU TIMER                  3064 12860000
*                                                                  3064 12870000
*   CREATE HISTOGRAM OF CPU TIME AT LOW PRIORITY                   3064 12880000
*                                                                  3064 12890000
         L     HISTVAL,TIMEHI      CPU TIME AT SETLO               3064 12900000
         ST    0,TIMEHI      SAVE FOR USE BY APLSETLO              3064 12910000
         SLR   HISTVAL,0      CPU TIME AT LOW PRIORITY             3064 12920000
         LA    PHR,PERHLCPU   LOW PRIORITY HISTOGRAM               3064 12930000
         BAL   LINK,HISTCOMP                                       3064 12940000
         LH    0,CHAPHI      DISPATCHING PRIORITY INCREMENT        3064 12950000
         LM    2,3,LOWLIM     DSETHI EVENT                         3586 12960000
ASL3     BALR  PTR,0          ESTABLISH ADDRESSIBILITY             3586 12970000
         USING *,PTR                                               3586 12980000
         L     1,ACHAPCDE     CHAP VALUE LOCATION IN APLM          3586 12990000
         NC    0(2,1),0(1)    IS CHAPCODE CURRENTLY ZERO?          3586 13000000
         BZ    ASLZ             AS IT SHOULD BE.                   3586 13010000
* IF CHAPCODE IS NON-ZERO,WE MISSED ATLEAST ONE CHAP.              3586 13020000
* I.E. MOTHER HAS NOT BEEN DISPATCHED SINCE CHAP                   3586 13030000
*      WAS LAST SET.                                               3586 13040000
         CH    0,0(1)              EQUAL?                          3586 13050000
         UGH   E                   CAN'T BE                        3586 13060000
         SR    0,0                 IGNORE THIS CHAP                3586 13070000
         LH    5,ASLCTR            COUNT HOW OFTEN                 3586 13080000
         LA    5,1(5)              WE HAVE MISSED                  3586 13090000
         STH   5,ASLCTR            ONE CHAP                        3586 13100000
ASLZ     STH   0,0(1)              SAVE NEW CHAP CODE              3586 13110000
         XI    SETHILO,SHLCUR                                      3064 13120000
*                   STOP CYCLE AT HIGH PRIORITY?                   3064 13130000
         TM    SETHILO,SHLSTOPH+SHLCUR                             3064 13140000
         BO    APLSETNO       YES, SO DON'T ENQUEUE TIMER EVENT    3064 13150000
         DROP  PTR                                                 3064 13160000
ASLZ2    L     0,REALTIME                                          3064 13170000
         BAL   5,ENQIET                                                 13230000
         B     EXTIM2                                                   13270000
         SPACE 2                                                   3064 13330000
APLSETNO NI    SETHILO,NOT-SHLSTOPH-SHLACTIV    SET FLAGS TO       3064 13340000
*    INDICATE THAT THE APLSETHI/SETLO LOOP HAS BEEN STOPPED        3064 13350000
         B     EXTIM2                                              3064 13360000
         SPACE 3                                                   3064 13370000
*  CPU TIME AT HIGH PRIORITY                                       3064 13380000
         SPACE 2                                                   3064 13390000
*  1/300 SECONDS PER UNIT                                          3064 13400000
*HCPU    PHGEN 300*128,300,16                                      3064 13410000
HCPU     PHGEN 300*128,300,16                                      3064 13420000
         SPACE 3                                                   3064 13430000
*   CPU TIME AT LOW PRIORITY                                       3064 13440000
*                                                                  3064 13450000
*  1/300  SECONDS PER UNIT                                         3064 13460000
*LCPU    PHGEN 300*128,300,17                                      3064 13470000
LCPU     PHGEN 300*128,300,17                                      3064 13480000
         EXTRN CHAPCODE                                            3064 13490000
         ENTRY CHAPLOW                                                  13500000
ASLCTR   DC    H'0'                COUNT MISSED CHAPS              3586 13510000
ACHAPCDE DC    A(CHAPCODE)         PRIORITY CHANGE VALUE IN MOTHER.     13520000
CHAPLOW  DC    H'-255'                                                  13530000
CHAPHI   DC    H'255'                                                   13540000
PPERQ    DC    F'65536000'         PORTS PER ADDITIONAL QUANTUM         13560000
PPERN    DC    F'32768'            PRIORITY PROPORTION WITH NO USERS    13570000
*              INITIAL PROPORTIONS ARE 50 PERCENT TO APL                13580000
         MEXIT                                                          13590000
         MEND                                                           13650000
         SPACE 1                                                        13660000
         MACRO                                                          13670000
         SVINIT                                                         13680000
*                                                                       13700000
*        NOTE THAT THE FOLLOWING CODE IS OVERLAID BY HI & PA BUFFERS    13710000
*        ENTERED FROM SUPINI TO START EXECUTION                         13720000
*        NOTE THAT BROADBF COUNT SHOULD = 0 FOR OPFNS USE               13730000
*                                                                       13740000
         USING SVINIT,10                                                13750000
         USING MPXSAVE,MR                                               13760000
         USING APLLOW,14                                            K01 13780000
SVINIT   MVC   SVCTAB+2*YYQZ,SVINIT1   SETUP PROPER TABLE ENTRY         13800000
         LM    0,5,REGSV-M(PXR)    LOAD ITBREGS SETUP BY SIPINI         13810000
         BALR  LINK,4              CREATE CHAIN OF FREE TYPEWRITER BUFS 13860000
         TIME  TU                                                  3060 13880000
         ST    1,OSDATE           INITIALIZE THE DATE              3060 13890000
         B     QUEND               ENTER SCHEDULER                      13910000
SVINIT1  DCY   QUEND               4 QUANTUM END                        13920000
         LTORG                                                          14000000
         DROP  10,MR                                                    14010000
*                                                                       14020000
         ORG   BROADBF                                                  14030000
         DC    H'0'                INITIAL PA LENGTH = 0 FOR OPFNS      14040000
         MEXIT                                                          14060000
         MEND                                                           14090000
         SPACE                                                          14100000
         MACRO                                                          14110000
&L       CLIS  &A,&S                                                    14120000
.*       CLI WITH RELOCATABLE MASK.                                     14130000
&L       DC    0H'0',AL4((0-X'6B00')*X'10000'+&S-APLSVC)                14140000
         ORG   *-2                                                      14150000
         DC    S(&A)               BASE, DISPLACEMENT.                  14160000
         MEND                                                           14170000
         SPACE 1                                                        14180000
         MACRO                                                          14190000
         PTSET &BYTE               NOTE IMPLICIT SETTING OF PT BITS     14200000
         AIF   ('&BYTE' NE 'ACTIVE').P2                                 14220000
         DC   0AL1(ATTENM+OUTWAITM+INWAITM+NONINM+LOCKM+MISCM)          14240000
         MEXIT                                                          14250000
.P2      AIF   ('&BYTE' NE 'MISCB').P3                                  14280000
         DC   0AL1(NOWSM+EXCPWM+WANTON+SDWAIT+REPWAITM+TRAWAITM+CLOKWAI*14300000
               T+BUFFWAIT)                                              14310000
         MEXIT                                                          14320000
.P3      AIF   ('&BYTE' NE 'IOB1').P4                                   14350000
         DC    0AL1(TRREJ+COPYRM+COPYWM+BROADM+RINGM+NSIGNM+PRIVBIT)    14370000
         MEXIT                                                          14380000
.P4      AIF   ('&BYTE' NE 'IOB2').P5                                   14410000
         DC   0AL1(Q4WMDM+RECMM+LVIDLEM+LOEXP+SHEXP+BOUNCM)             14430000
         MEXIT                                                          14440000
.P5      MEND                                                           14460000
         MACRO                                                     2217 14470000
&L       SET   &SW,&MASK                                           2217 14480000
&L       OI    &SW,&MASK                                           2217 14490000
         AIF   ('&SW' NE 'UGHSW').NOUGHSW                          2217 14500000
         MVC   UGHSWTRC(L'UGHSWTRC),UGHSWTRC+1                     2217 14510000
.NOUGHSW ANOP                                                      2217 14520000
         MEND                                                      2217 14530000
         MACRO                                                     2217 14540000
&L       RESET &SW,&MASK                                           2217 14550000
&L       NI    &SW,X'FF'-&MASK                                     2217 14560000
         MEND                                                      2217 14570000
         SPACE 1                                                   2219 14580000
         MACRO                                                     2219 14590000
&L       TTIMERS                                                        14600000
*                                                                  2219 14780000
*        SINCE WE ARE EXECUTING UNDER  TCBMERE ,  WE KNOW          2219 14790000
*        THAT THE TQE FOR  TCBFILLE  IS NOT ON THE QUEUE           2219 14800000
*                                                                  2219 14810000
&L       L     1,TCBFILLE     ADDRESS OF SUBTASK TCB               2219 14820000
         L     1,TCBTME(,1)   ADDRESS OF TQE, IF ANY               2219 14830000
         LTR   0,1            IS THERE A TQE?   ZERO IF NOT        2219 14840000
         BZ    *+8   *******  RETURN 0 IF NO TQE                   2219 14850000
         USING TQE,1                                               2219 14860000
         L     0,TQEVAL       TIME REMAINING                       2219 14870000
         DROP  1                                                   2219 14880000
         MEND                                                      2219 14890000
         SPACE 1                                                   2219 14900000
         SPACE 1                                                        14910000
         PRINT ON                                                       14920000
         TITLE 'A P L S U P   P R E F I X   S T O R A G E     05/11/70' 14930000
         LCLA  &TEMPA                                                   14960000
         LCLC  &TEMPC1,&TEMPC2                                          14970000
         LOWCORE                   , DSECT VS CSECT                     14990000
         SPACE 3                                                        15000000
PERDEVXG CSECT                                                          15010000
         DS    1F                  PREVENT PTTYPE OF ZERO               15020000
*        HDIR CSECT MUST BE DEFINED BEFORE HTAB, BECAUSE EXMHIST MUST   15030000
*        BE ABLE TO CHECK IF HTAB WAS OMITTED & IS REFERENCED.          15040000
HDIR     CSECT ,                   HISTOGRAM DIRECTORY                  15060000
         DC    A(HDIRZ-HBASE)      END OF TABLE                         15070000
HBASE    EQU   *                                                        15080000
*                                                                       15100000
MAXQUAN  EQU   30     = 100 MILSEC                                      15110000
PANICINT EQU   20*MAXQUAN          WAIT A BIT BEFORE WE PANIC           15130000
*  IF THE INTERPRETER IS IN LCS, PANICINT PROBABLY SHOULD BE LARGER K10 15180000
LIRSINT  EQU   10*300         10 SEC TIMEOUT FOR DATA SET NOT READY     15190000
WIRSINT  EQU   150            HALF SECOND                               15200000
TWOSEC   EQU   600               TWO SECOND MPX DELAY                   15210000
MINQUAN  EQU   9*MAXQUAN           DOS TO APL RATIO                     15220000
MINUTE   EQU   60*300              ONE MINUTE IN APL CLOCK UNITS        15230000
HOUR     EQU   60*MINUTE                                                15240000
OFFHLIM  EQU   1*MINUTE            SIGN OFF HOLD LIMIT                  15250000
EXPLIM   EQU   8*MINUTE            EXPRESS TERMINAL CONNECT DURATION    15260000
F        EQU   256                 FOR 32 BIT ADCON DEFINITION          15270000
NOT      EQU   X'FF'          FOR USE IN BUILDING COMPLEMENT MASKS C022 15280000
ALL      EQU   X'FF'                                               2217 15290000
IDLMAX   EQU   10                  MAXIMUM READ IDLES FOR 2741 OR 2740  15300000
SELERMX  EQU   20 ERRORS SAME TRACK, ASSUME NON RECOVERABLE             15310000
TIMEFUZ  EQU   1              FORCED ERROR IN SETINT CALLS              15320000
CPMAXBUF EQU   20                  INPUT BUFFER ALLOCATION              15330000
         COPY  APLDEFN                                                  15340000
         DROP  MR                                                       15350000
CONCEAL  EQU   WFLLIB                                                   15360000
MEMAD    EQU   REGSV+4*MR                                               15370000
LINK     EQU   15                                                       15380000
SIGR     EQU   5                                                        15390000
PTR      EQU   MR+1           PERTERM BASE REGISTER                     15410000
PXR      EQU   PTR+1               PERDEVX  OR M  BASE REG IN MPX,SVC   15460000
HISTVAL  EQU   1                 MUST BE AN ODD REGISTER                15470000
PHR      EQU   3                   HISTCOMP BASE REGISTER               15480000
*                                                                       15490000
         COPY  ZSYMBOLS                                                 15500000
         COPY  DIRSECT                                                  15520000
         COPY  PERTERM                                                  15540000
TBLM1    EQU   TBL-1                                                    15550000
*                                                                       15560000
APLSUP   CSECT                                                          15570000
         TITLE 'A P L   -   M V T    I N T E R F A C E'                 15600000
*                                                                       15610000
*        MVT TIMER INTERFACE.                                           15620000
*                                                                       15630000
*        APLSUP TIMER CODE ALWAYS RUNS ON THE MOTHER TCB.               15640000
*                                                                       15650000
*        THE TIMER COMPLETION EXIT ROUTINE RESIDES IN THE REAL MOTHER   15660000
*        TASK AND CONSISTS OF THE FOLLOWING ..                          15670000
*                                                                       15680000
*        1.    GOTO 3 IF ECBMERE NE WAIT.                               15690000
*        2.    POST ECBMERE                                             15700000
*        3.    EXOLDPSW IS RBMERE.(RBOPSW).                             15710000
*        4.    RBMERE.(RBOPSW). IS X'00040000',A(EXINT)                 15720000
*        5.    GOTO OS                                                  15730000
*                                                                       15740000
*        THE REAL MOTHER TASK CONSISTS OF THE FOLLOWING.                15750000
*LOOP    WAIT  ECB=ECBMERE                                              15760000
*        B     LOOP                                                     15770000
*                                                                       15780000
*        THE FOLLOWING OCCURS AT EXRET.                                 15790000
*                                                                       15800000
*        1.    GOTO 3 UNLESS (ECBFILLE = WAIT) AND RESCH NE 0           15810000
*        2.    POST ECBFILLE                                            15820000
*        3.    LPSW EXOLDPSW                                            15830000
*        NOTE - EXOLDPSW IS THE MOTHER PRB RESUME PSW AFTER STEP 1 OF   15840000
*        THE TIMER COMPLETION EXIT ROUTINE.                             15850000
*                                                                       15860000
         ENTRY EXINT                                                    15870000
*                                                                       15880000
*        AT ENTRY, STORAGE KEY IS EITHER ZERO OR THAT OF REGION.        15890000
*        NOTE...  MOTHER'S R10 IS DESTROYED.                            15900000
EXINTPSW DC    0D'0',X'00040000',A(EXTIME)                              15910000
EXINT    EQU   *                                                   3054 15920000
*                                                                  3054 15930000
*        IONEWPSW (LOCATION X'78') IS USED BY SSM BELOW SINCE      3054 15940000
*        WE DO NOT HAVE ADDRESSABILITY. FIRST BYTE OF IONEWPSW     3054 15950000
*        SHOULD ALWAYS BE ZERO.                                    3054 15960000
*                                                                  3054 15970000
         SSM   IONEWPSW           DISABLE ALL INTERRUPTS           3054 15980000
         DC    0AL4(ALLOFF)       SO DISABLE CAN BE FOUND IN XREF  3054 15990000
         ST    10,PINHEDD         SAVE REG ACROSS BALR             3054 16000000
         BALR  10,0               ADDRESSABILITY                   3054 16010000
         USING *,10                                                     16020000
         STM   0,15,APLSAVE        KEY HERE SHOULD MATCH.               16030000
         MVC   APLSAVE+40(4),PINHEDD    SAVE REG 10 IN APLSAVE     3054 16040000
         L     14,APLBASE                                               16050000
         DROP  10                                                       16060000
         USING APLLOW,14                                                16070000
         MVI   EXINTLK,X'80'       INICATE WE ARE NOW IN EXINT     3572 16080000
         SET   UGHSW,EXTERNAL                                      2217 16090000
         LPSW  EXINTPSW            THIS IS REALLY   B EXTIME            16100000
*                                                                       16110000
*        RETURN FROM EXTERNAL INTERRUPT.                                16120000
*                                                                       16130000
EXRET    RESET UGHSW,EXTERNAL                                      2217 16140000
         CLI   RESCH,0             SEE IF DISPATCHING REQUIRED.    2217 16150000
         BE    EXRET2              BRANCH IF NO TASK SWITCH REQUIRED.   16160000
         SPACE                                                          16170000
*                                                                       16180000
*        IF RESCH IS NON-ZERO, AND APL IS WAITING AT QZA7,              16190000
*        POST DAUGHTER TASK.                                            16200000
*                                                                       16210000
         SPACE                                                          16220000
         MVI   RESCH,0                                                  16230000
         BAIL                                                           16240000
*        DISPATCH MOTHER TASK, WHICH WILL IMMEDIATELY WAIT.             16250000
EXRET2   MVI   EXINTLK,0                                                16260000
         MVC   PINHEDD(8),EXOLDPSW                                 3054 16270000
         LM    0,15,APLSAVE                                             16280000
         LPSW  PINHEDD                                             3054 16290000
         EJECT                                                          17250000
         SVINT ,                   APL SVC PASSED/STOLEN FROM HOST      17260000
         EJECT                                                          17270000
*                                                                       17280000
         DC    0F'0',C'PSWI'       FOR THE SWAPPING CONVENTION          17290000
HOSTIOP  DC    X'00040000',A(IOINT)     THE PSW                         17300000
IOINT    ST    1,PINHEDD                                           C043 17310000
         BALR  1,0                                                      17320000
         USING *,1                                                      17330000
         STM   0,15,APLSAVE                                             17340000
         MVC   APLSAVE+4(4),PINHEDD                                C043 17350000
         LM    MR,14,SVBASE        LOAD MR AND 14                       17360000
         USING MPXSAVE,MR                                               17370000
         DROP  1                                                        17380000
         USING APLLOW,14                                                17390000
         LH    1,IOOLDPSW+2                                             17400000
         BAL   3,IODADV                                                 17410000
         CLC   IOOLDPSW+2(1),MPXCHANL                              5991 17420000
         BE    MPXINT                                                   17430000
*        REJECT I/O INTERRUPT; PASS ON TO NEXT INTERCEPTOR OR HOST      17440000
IOREJ    MVC   PINHEDD(8),HOSTIOP  PASS INTERRUPT TO HOST               17450000
         LM    0,15,APLSAVE                                             17460000
         LPSW  PINHEDD                                                  17470000
         DROP  MR                                                       17480000
         DROP  14                                                       17490000
*                                                                       17500000
         EJECT                                                          17730000
*                                                                       17740000
*        MVT SELECTOR CHANNEL END APPENDAGES.                           17750000
*                                                                       17760000
*        *** NOTE *** NO SVC'S MAY BE ISSUED FROM AN OS END APPENDAGE.  17770000
*                                                                       17780000
*        ON ENTRY ..                                                    17790000
*                                                                       17800000
*        R1    ADDRESS OF REQUEST ELEMENT.                              17810000
*        R2    ADDRESS OF IOB.                                          17820000
*        R3    ADDRESS OF DEB.                                          17830000
*        R4    ADDRESS OF DCB.                                          17840000
*        R7    ADDRESS OF UCB                                           17850000
*        R14   OS RETURN ADDRESS.                                       17860000
*        R15   ENTRY POINT (LOADED BY IOS)                              17870000
*                                                                       17880000
*        ABNORMAL END APPENDAGE.                                        17890000
*        ENTERED ON  OR/UC, CHAINCHK, PROGCHK, PROTCHK .                17900000
*                                                                       17910000
*        IOS HAS OBTAINED SENSE WHICH IS NOW IN THE UCB.                17920000
*        THE ERROR CSW IS IN THE IOB.                                   17930000
*                                                                       17940000
         ENTRY HOSTIOP                                                  17950000
         ENTRY SELXEN                                                   17960000
         USING SELXEN,15                                                17970000
*        ABNORMAL APPENDAGE ENTRY.                                      17980000
* IF AN UNSOLICITED INTERRUPT ACCURS, IOS MAY 'INTERCEPT' AN EXCP AND   17990000
* ENTER THE APPENDAGE WITH A CC OF X'7E'. .  IN THIS CASE, WE REJECT    18000000
* THE INTERRUPT AND REQUEST A RESTART.                                  18010000
SELXEN   CLI   IOBECBCC-IOBD(2),X'7E'                                   18020000
         BE    8(14)               REQUEST RESTART.                     18030000
         OI    SWITCHES,SELAPENT   NOTE THAT WE ENTERED APPENDAGE  DASD 18040000
         MVC   MVTCSW(8),CSW       SAVE REAL CSW.                       18050000
         MVC   CSW+1(7),IOBCSW-IOBD(2) MOVE CSW FROM IOB TO LOW CORE.   18060000
         SPACE                                                          18070000
         BAL   15,SELCOMN     ENTER COMMON APPENDAGE CODE, AND     C022 18080000
*              SET UP NEW BASE REGISTER                            C022 18090000
*  NOTE ASSUMPTION THAT  SELPCIX  IMMEDIATELY FOLLOWS THIS BAL     C022 18100000
         SPACE 3                                                   C022 18110000
         USING SELPCIX,15                                               18120000
         SPACE                                                          18130000
*                                                                       18140000
*        MVT NORMAL END APPENDAGE.                                      18150000
*                                                                       18160000
*        ENTERED ON ..                                                  18170000
*        (CE OR CE AND UE OR IL) AND NO OTHER STATUS.                   18180000
*        (DE IS IGNORED).                                               18190000
SELCE    EQU   SELXEN              NORMAL APPENDAGE ENTRY.              18200000
*                                                                       18210000
*        MVT PCI APPENDAGE.                                             18220000
*        ENTERED ON PCI.                                                18230000
*                                                                       18240000
         SPACE                                                          18250000
         ENTRY SELCE                                                    18260000
         ENTRY SELPCIX                                                  18270000
SELPCIX  MVC   MVTCSW(8),CSW       PCI APPENDAGE ENTRY.                 18280000
*                                                                   PCI 18290000
         TM    CSW+5,X'7F'                                          PCI 18300000
         BZ    SELCOMN                                              PCI 18310000
PCISTOP  NOP   0                                                    PCI 18320000
         ENTRY PCISTOP                                              PCI 18330000
         LH    9,PCISTOP+2    COUNT HOW OFTEN                       PCI 18340000
         LA    9,1(9)         WE HAVE PCI WITH AN ERROR             PCI 18350000
         STH   9,PCISTOP+2    IN THE HALF WORD AT PCISTOP+2         PCI 18360000
*                                                                   PCI 18370000
*    SINCE PCI APPENDAGE CANNOT ASK FOR EXCP RESTART,               PCI 18380000
*        WE WILL WAIT FOR THE ABNORMAL END APPENDAGE TO HANDLE      PCI 18390000
*        THIS ERROR CONDITION.                                      PCI 18400000
*                                                                   PCI 18410000
         SR    9,9            FOR IOS                               PCI 18420000
         BR    14             RETURN TO IOS.                        PCI 18430000
*                                                                   PCI 18440000
SELCOMN  SR    10,10               INITIALIZE RETURN.              2217 18450000
         STM   0,15,APLSAVE                                        2217 18460000
         L     14,APLBASE          ESTABLISH APLSUP ADDRESSING.         18470000
         DROP  15                                                       18480000
         USING APLLOW,14                                                18490000
         SET   UGHSW,APPENDG                                       2217 18500000
         B     SELINT              COMMON ROUTINE.                      18510000
*                                                                       19400000
*                                                                       19410000
*        OURDISK IS NORMALLY EQUAL TO WORKDISK                          19430000
DIRCYL   DC    F'-1'               DIRECTORY DISK ADDRESS          DASD 19440000
ALTCYL   DC    F'-1'  PHYSICAL ADDRESS OF SECOND COPY OF DIRECTORY DASD 19450000
         EJECT                                                          19470000
         ENTRY PCBXLE                                                   19490000
         ENTRY PTBXLE                                                   19530000
SUPPARS  APLSUPC                                                        19550000
*                                                                       19560000
VALCON   EQU   ALEN+3                                                   19640000
*                                                                       19660000
         EXTRN MPXCUTAB                                                 19710000
AMXCUT   DC    A(MPXCUTAB)                                              19720000
PERDEVB  DC    A(PERDEVXG)         FOR DEVXCC                           19730000
*                                                                       19740000
UGHSWTRC DC    XL7'00'                                             2217 19750000
UGHSW    DC    X'00'                                               2217 19760000
MPXIO    EQU   1                                                   2217 19770000
SVC      EQU   2                                                   2217 19780000
EXTERNAL EQU   4                                                   2217 19790000
APPENDG  EQU   X'38'                                               2217 19800000
         TITLE 'UGH  CATASTROPHIC (BUT RECOGNIZED) SYSTEM FAILURE.' K01 19810000
         SPACE 3              START OF UGH ROUTINE                  K01 19820000
*        IN ORDER FOR US TO ARRIVE HERE,                            K01 19830000
*        R14 MUST HAVE BEEN POINTING TO APLLOW;                     K01 19840000
*        HOWEVER,                                                   K01 19850000
*        R14 WAS WIPED BY THE BAL THAT GOT US HERE;                 K01 19860000
*        ALL OTHER REGISTERS ARE STILL AS THEY WERE.                K01 19870000
*        WE WILL NOW SAVE ALL REGISTERS AND LOW CORE, (AT UGHS)     K01 19970000
*        FOR DEBUGGING PURPOSES.                                    K01 19980000
         DROP  14                                                   K01 19990000
         ENTRY UGHS                                                 SUG 20000000
UGH      STH   MR,2(14)      SAVE RIGHT-HALF  OF MR                 K01 20010000
         SRL   MR,16         GET LEFT-HAND OF REGISTER              K01 20020000
         STH   MR,0(14)      SAVE LEFT-HALF OF REGISTER             K01 20030000
         BALR  MR,0                                                 K01 20040000
         USING *,MR          ESTABLISHING ADDRESSIBILITY            K01 20050000
*                                                                   K01 20060000
*    TO PRESERVE APLSUP ADDRESSIBILITY, THE REMAINDER OF THE UGH    K01 20070000
*              CODE IS IN HIGH CORE.                                K01 20080000
*                                                                   K01 20090000
         L     MR,=A(UGHS)   ADDRESS OF UGH ROUTINE                 K01 20100000
         DROP  MR                                                   K01 20110000
         BR    MR            GO TO UGH PROCESSING ROUTINE           K01 20120000
         TITLE 'S E L E C T O R  C H A N N E L  A N D  G L O B A L  S UX20140000
                B R O U T I N E S'                                      20150000
         USING APLLOW,14                                                20170000
*                                                                       20190000
EXTIME   BAL   LINK,CORTIME   COMPUTE TIME OF DAY                       20200000
         MVI   IESW,1              PROCRASTINATE SETTING TIMER          20210000
         ENTRY EXTIM2         FOR USE BY MAKFR MACRO IN CONFIG          20220000
EXTIM2   L     1,=A(X'7FFFFF')     ARBITRARY SPECIFIC VALUE        3064 20230000
         CLI   IEHED+1,EMPTYM      INTERVAL EVENT QUEUE EMPTY Q         20240000
         BE    EXTIM5              YES. SET TIMER TO ARBITRARY VALUE.   20250000
         USING IEBLOCK,3                                                20260000
         L     3,IEHED                                                  20270000
         L     1,IETIME                                                 20280000
         S     1,REALTIME          :1 = EVENT IME - REALTIME            20290000
         BNH   EXTIM4              TRIGGER THIS EVENT                   20300000
*        SET TIMER TO TIME TILL EVENT IS DUE                            20310000
EXTIM5   MVI   IESW,0              ALLOW SETTING OF TIMER               20320000
         BAL   LINK,SETINT                                              20330000
         B     EXRET                                                    20340000
*        REMOVE EVENT FROM LIST AND TRIGGER IT                          20350000
EXTIM4   MVC   IEHED,IELINK                                             20360000
         MVC   IELINK,HD3FR    PUT EVENT BLOCK ON 3 WORD                20370000
         ST    3,HD3FR        FREE SPACE LIST                           20380000
*        EXAMINE IEBASE TO DETERMINE NEXT ACTION                        20390000
*        CONVENTIONS FOR IEBASE ARE:                                    20400000
*              WORD IS SPLIT 8,24                                       20410000
*              8 BITS DETERMINE EVENT TYPE                              20420000
*              24 BITS ARE PARAMETER FOR TRIGGERED ROUTINE              20430000
         USING MPXSAVE,MR                                               20440000
         L     MR,SVBASE      ESTABLISH MPX BASE REG                    20450000
         SR    10,10               EVENT TYPE CODE REGISTER             20460000
         IC    10,IEBASE                                                20470000
         MVI   IEBASE,0            CLEAR HIGH ORDER BYTE OF PTR         20480000
         L     PTR,IEBASE                                               20490000
         LH    10,IETAB(10)        EVENT ADDRESS                        20500000
         DEREL  ,                  DERELATIVIZE                         20510000
         BR    10                                                       20520000
         DROP  3                                                        20530000
IEBRN    BR    PTR                 BRANCH TO NON-PTR ROUTINE            20540000
IETAB    IETGEN MPX                MUST BE FIRST EVENT TYPE             20550000
         IETGEN SOHK               SIGN OFF HOLD KILL                   20560000
         IETGEN CLOK               BREAK CLOCK WAIT                     20570000
         IETGEN BRN                BRANCH TO IEBASE                     20580000
         IETGEN SZUG               EXPRESS TERMINAL AUTOMATIC BOUNCE    20590000
         DROP  MR                                                       20600000
*                                                                       20610000
*        ENQIE ENQUEUES INTERVAL TIMER EVENTS                           20620000
*        R2 = IEBASE SETTING FOR USE AT EXTIM4 (DESCRIBES EVENT)        20630000
*        R3 = INTERVAL TO ELAPSE FROM TIME ENQIE IS CALLED TO           20640000
*              WHEN EVENT IS DESIRED                                    20650000
*        TWO ENTRANCES, EQIE NORMAL, ENQIET REALTIME IN R0,SSM ALLOFF   20660000
*        R5 = RETURN                                                    20670000
ENQIE    BAL   LINK,CORTIME                                             20680000
ENQIET   CLI   HD3FR+1,EMPTYM CHECK FOR FREE SPACE                      20690000
         UGH   E                   NO MORE LIST SPACE                   20700000
         AR    3,0                 IETIME SETTING = REALTIME+INTERVAL   20710000
         L     1,HD3FR                                                  20720000
         USING IEBLOCK,1                                                20730000
         MVC   HD3FR,IELINK                                             20740000
         ST    2,IEBASE                                                 20750000
         ST    3,IETIME                                                 20760000
         LA    4,IEHED+IEBLOCK-IELINK                                   20770000
ENQ3     LR    2,4            ADVANCE                                   20780000
         CLI   IELINK+1-IEBLOCK(2),EMPTYM                               20790000
         L     4,IELINK-IEBLOCK(2)                                      20800000
         BE    ENQ4           END OF IE LIST                            20810000
         C     3,IETIME-IEBLOCK(4)                                      20820000
         BH    ENQ3           CONTINUE SEARCH                           20830000
ENQ4     ST    4,IELINK       INSERT INTO QUEUE                         20840000
         ST    1,IELINK-IEBLOCK(2)                                      20850000
         C     1,IEHED             SEE IF IN SERTION IS TOP OF LIST     20860000
         BCR   7,5  BNER      NO, RETURN TO CALLER                      20870000
         L     1,IETIME       NEW EVENT IS SOONEST                      20880000
         DROP  1                                                        20890000
         SR    1,0            RECOMPUTE INTERVAL                        20900000
         BCR   4,5  BMR            AVOID NEGATIVE TIMER                 20910000
         LA    1,TIMEFUZ(1)                                             20920000
         LR    LINK,5         DECREASE INTERVAL TIMER SETTING           20930000
         B     SETINT                                                   20940000
*                                                                       20950000
*        PRGIE REMOVES AN EVENT FROM INTERVAL TIMER QUEUE               20960000
*        R1= IEBASE VALUE TO BE PURGED                                  20970000
*        LINK = RETURN                                                  20980000
PRGIE    LA    4,IEHED+IEBLOCK-IELINK                                   20990000
PRG2     LR    2,4            ADVANCE                                   21000000
         CLI   IELINK+1-IEBLOCK(2),EMPTYM                               21010000
         BCR   8,LINK              EVENT NOT FOUND.                     21020000
         L     4,IELINK-IEBLOCK(2)                                      21030000
         C     1,IEBASE-IEBLOCK(4)                                      21040000
         BNE   PRG2                                                     21050000
         MVC   IELINK-IEBLOCK(4,2),IELINK-IEBLOCK(4)  DEQUEUE           21060000
         MVC   IELINK-IEBLOCK(4,4),HD3FR     SALVAGE BLOCK              21070000
         ST    4,HD3FR                                                  21080000
PRG1     BR    LINK                                                     21090000
*                                                                       21100000
*        R1 IS NEW TIMER VALUE                                          21110000
*        R0 ON EXIT IS NEW TIME OF DAY                                  21120000
*        R2 IS DISTURBED                                                21130000
SETINT   SSM   ALLOFF                                                   21140000
         TM    IESW,1              EXTERNAL INTERRUPT IN PROCESS?       21150000
         BO    SETINTZ             YES. DON'T SET ALARUM YET.           21170000
         SLL   1,7                 MULTIPLY BY 128 (OS UNITS)           21560000
         LR    0,1                 HOLD INTERVAL VALUE.                 21570000
         L     1,ATQE                                                   21580000
         USING TQE,1                                                    21590000
         L     2,CVT               GET ADDRESS OF CVT                   21600000
         STM   14,13,LAMSAVE                                            21610000
*      THESE TESTS ARE MADE HERE TO INSURE THAT A TQE IS NOT ENQ'D 3572 21620000
* IF THE PREVIOUS TQE HAS EXPIRED AND HAS NOT BEEN PROCESSED YET   3572 21630000
* BY EXINT. IN THIS CASE THE ENQ IS IGNORED AND CONTROL RETURNED   3572 21640000
* TO THE CALLER.                                                   3572 21650000
         TM    TQEFLGS,X'80'       IS TQE ON THE QUEUE?            3572 21660000
         BO    INTLKCHK            NO-CHECK INTERLOCK BEFORE DEQ   3572 21670000
         CLI   EXINTLK,X'00'       INTERLOCK SHOULD NOT BE ON IF   3572 21680000
         UGH   NE                  TQE IS ON THE QUEUE. IF SO,UGH  3572 21690000
         L     10,CVTTPC(2)        ADDR. OF OS PSEUDO CLOCKS       3572 21700000
         L     2,CVTQTD00(2)       TQE DEQ RTN.                         21710000
         BALR  2,2                                                      21720000
         USING *,2                                                      21730000
         LM    14,2,LAMSAVE                                             21740000
         DROP  2                                                        21750000
         B     SETINTOQ            ENQ TQE                         3572 21760000
INTLKCHK CLI   EXINTLK,X'80'       PREVIOUS TQE BEING PROCESSED?   3572 21770000
         BNE   SETINTZ             NO-DO NOT ENQ                   3572 21780000
         L     10,CVTTPC(2)        ADDR. OF OS PSEUDO CLOCKS       3572 21790000
SETINTOQ MVC   TQE(TQEGRS-TQEFLGS),TQEPSECT                             21800000
         ST    0,TQEVAL            INTERVAL.                            21810000
         L     2,CVTQTE00(2)       A(IEAQTE00) = TQE ENQ RTN.           21820000
         BALR  2,2                                                      21830000
         USING *,2                                                      21840000
         LM    14,13,LAMSAVE                                            21850000
         DROP  2,1                                                      21860000
*                                                                       21870000
SETINTZ  L     0,REALTIME                                               21880000
         BR    LINK                                                     21890000
LAMSAVE  DS    16F                                                      21900000
         SPACE 2                                                        21910000
         EJECT                                                          21920000
*        NOTES ON USE OF BRANCH ENTRY TO TQE ENQ AND DEQ ROUTINES.      21930000
*        THE BRANCH INTERFACE MUST BE USED BECAUSE AN INITIATOR         21940000
*                                  WAITING FOR SQA WILL BE DISPATCHED   21950000
*                                  IF WE ISSUE A STIMER.                21960000
*                                  (WHEN THE SVRB IS DEQUEUED)          21970000
*                                                                       21980000
*                                  INITIATORS ARE USUALLY ENABLED, AND  21990000
*                                  MAY ALLOW A MULTIPLEX INTERRUPT      22000000
*                                  TO BE TAKEN BEFORE WE ARE READY FOR  22010000
*                                  IT.                                  22020000
*                                                                       22030000
*        R1 IS A(TQE)  HIGH ORDER BIT MUST BE SET PROPERLY IN TQE.      22040000
*                                  ON (INDICATING OFF QUEUE) FOR ENQ.   22050000
*                                  OFF FOR DEQ.                         22060000
*        R2 IS RETURN ADDRESS.                                          22070000
*        R10 MUST POINT TO THE PSEUDO CLOCKS.                           22080000
*                                  (BECAUSE DEQ ENTRY MAY NEED IT).     22090000
*        IF YOU MODIFY THIS INTERFACE, TAKE PAINS TO ENSURE THAT WE DO  22100000
*                                  NOT LOSE THE IRB IN THE TCER.        22110000
*                                  CURRENT METHOD IS TO SET RBSTAB+1    22120000
*                                  NI RBSTAB+1,X'F9'                    22130000
*                                                                       22140000
         SPACE 2                                                        22150000
OSDATE   DS    F                                                        22160000
CORTIME  SSM   ALLOFF              GET TIME OF DAY.                     22170000
         ST    15,S15FOS                                                22180000
         TIME  TU                  OS TIME SVC. TIME RETURNS IN R0.     22190000
         SRL   0,7                 X 128 TO GET SECONDS DIV 300.        22200000
         A     0,DAYSUP            NUMBER OF DAYS SINCE INITIATION.     22210000
         C     1,OSDATE                                                 22220000
         BE    CORTIMEZ                                                 22230000
         ST    1,OSDATE                                                 22240000
* NOTE: APL MAY GET SLEEPY FOR A WHILE IF CLOCK IS SET,                 22250000
* BUT ABOVE SHOULD PREVENT DISASTER.                                    22260000
*                                  IN SECONDS DIV 300.                  22270000
*        IF THE MVT OPERATOR SETS CLOCK WHILE APL IS RUNNING,           22280000
*        STRANGE THINGS WILL HAPPEN.                                    22290000
         L     1,DAYSUP            ASSUME IT IS MIDNIGHT.               22300000
         A     1,K24HOURS          AND INCREMENT THE NUMBER OF DAYS     22310000
         ST    1,DAYSUP            SINCE INITIATION.                    22320000
         A     0,K24HOURS          ADJUST TIME OF DAY.                  22330000
CORTIMEZ L     15,S15FOS           RECOVER R15.                         22340000
         ST    0,REALTIME                                               22350000
         BR    LINK                NOTE THAT SYSTEM MASK IS NOT RESTORE 22360000
*                                                                       22380000
         EJECT                                                          22390000
KH255    DC    H'255'              CONSTANT FOR TYOSUB,ETC.             22430000
ALLOFF   EQU   KH255                                                    22440000
ALLON    EQU   KH255+1        POINT TO X'FF'                        K10 22450000
*                                                                       22460000
*                                                                       22470000
*        IO INTERRUPT ANALYSIS                                          22480000
*        SELECTOR CHANNEL ROUTINES NEVER USE MR                         22490000
         SELINT                                                         22500000
         CLI   CSW+5,0                                                  22510000
         BNE   SELCS               CHANNEL STATUS                       22520000
         CLI   CSW+4,CE+DE                                              22530000
         BE    SELNOR              NORMAL END (CE,DE)                   22540000
*        UNUSUAL DEVICE STATUS ON SEL CHAN INTERRUPT                    22550000
         TM    CSW+4,UC+UE                                              22560000
         BZ    SELEXIT                                             2221 22580000
SELDS4   L     10,=A(SELSTAR)                                           22690000
         BAL   LINK,SELRTRY-SELSTAR(10)                                 22700000
         B     SELEXIT                                                  22710000
*                                                                       22720000
SELCS    EQU   *                                                    PCI 22770000
         TM    CSW+5,IL+PRC+CDC+CCC+ICC+CHC                             22800000
         BZ    SELCS1              PROGRAM CHECK                        22810000
         TM    CSW+5,PC+PRC+CDC+CCC+ICC IL AND CHAIN CHK RETRYABLE 5994 22830000
         BZ    SELDS4              RETRY FROM LAST SEEK.           5994 22840000
*                                                                  DASD 22860000
*                             BAD CHANNEL STATUS                   DASD 22870000
*                                                                  DASD 22880000
*                             REQUEST OS ERROR RECOVERY            DASD 22890000
         B     SELEXIT        -- OR AT LEAST A LOGOUT              DASD 22900000
*                             SELBUSY MUST BE 1                    DASD 22910000
*                                                                  DASD 22920000
*                                                                       22970000
*   PCI WAS DELAYED UNTIL END OF READ AND PROG CHECK RESULTED           22990000
SELCS1   TM    CSW+5,PCICSW        PCI AND PC ?                    2540 23000000
*                             IF PCI IS SET, WE HAVE NOT BUILT     5989 23010000
*                             THE REMAINING CCW CHAIN              5989 23020000
         BNO   SELCS1C        IF PCI IS NOT SET, WE HAVE BUILT     5989 23030000
*                THE CCW CHAIN, BUT THE CHANNEL BEAT US TO THE     5989 23040000
*                TIC.   WE NOW CHECK FOR CCCX FORCED ERROR         5989 23050000
SELCS1B  EQU   *                                                   5989 23060000
         BAL   6,CDCOMP            SETUP CCW CHAIN                      23070000
SELCS1C  CLI   SELFERR,1      CHECK FOR CCCX FORCED ERROR          5989 23080000
         BE    SELDS4              READ ERROR DETECTED BY CDCOMP        23090000
         CLI   ONETRK,0            DID FIRST TRACK CONTAIN ENTIRE WS -- 23100000
         BE    SELNOR2             YES, TREAT AS NORMAL READ END   5989 23110000
         L     0,=A(CCWAR+32)      CAW SETTING                          23120000
         SELTIME   ,                                               C022 23140000
*                                                                       23150000
*        PCI ON SELECTOR CHANNEL, SETUP CCW CHAIN FOR SUBSEQUENT TRACKS 23170000
SELPCI   BAL   6,CDCOMP                                                 23180000
         CLI   SELFERR,1           CDCOMP MAY HAVE DETECTED ERROR       23190000
         BE    SELEXIT             RETRY FROM SELCS1 AT PROG CHECK      23200000
         CLI   ONETRK,0            CHECK FOR ONE TRACK WORKSPACE.       23210000
         BE    SELSNOP                                                  23220000
*        NOTE THAT COMMAND CODE IN RD1A REMAINS ZERO UNTIL AFTER LAST   23230000
*        BYTE OF ADDRESS HAS BEEN STORED.  MODEL 40 TIMING PROBLEMS     23240000
*        ARE POSSIBLE IF LITERAL  A(CCWAR+32) IN FOLLOWING L 0,=        23250000
*        IS REPLACED BY   CCW    TIC,CCWAR+32                           23260000
         L     0,=A(CCWAR+32)      SEEK CCW FOR SECOND TRACK            23270000
         ST    0,RD1A                                                   23280000
         MVI   RD1A,TIC            KILL CHANNEL PROG CHECK              23290000
         B     SELEXIT                                                  23300000
*        READING FIRST AND ONLY TRACK OF WORKSPACE                      23310000
SELSNOP  MVI   RD1A,3              IONOP                                23320000
         MVC   EXPCSW(8),NOPCSW                                         23330000
         B     SELEXIT                                                  23340000
*                                                                       23360000
*        GOOD END OF DISK OPERATION                                     23370000
SELNOR   CLI   SELBUSY,1           CHECK FOR RE-ENTRY OF APPENDAGE.     23380000
         BNE   SELEXIT             IGNORE UNREQUESTED INTERRUPT.        23390000
         CLC   CSW+1(7),EXPCSW+1                                   2540 23400000
         UGH   NE                  SOMEBODY IS WRONG                    23410000
         CLC   EXPCSW+1(3),NDCCSW+1 WAS THIS A NON DATA CHAINED OP 5989 23420000
         BE    SELCS1B             YES                             5989 23430000
         CLI   CDOP,6         IS THE OPERATION A SAVE              5989 23440000
         BNE   SELNOR2        NO, MOVE NOT NECESSARY               5989 23450000
         CLI   ONETRK,INCORMV WAS THE DATA MOVED IN CORE ?         5989 23460000
         BNE   SELNOR2        NO, WE DONT HAVE TO MOVE IT BACK     5989 23470000
         L     1,CCPAR1       ADDRESS OF WORKSPACE                 5989 23480000
         USING M,1                                                 5989 23490000
         LM    2,3,MX         GET MX AND SVI                       5989 23500000
         DROP  1                                                   5989 23510000
         LA    2,7(,2)        ROUND MX TO A DOUBLE-WORD BOUNDARY   5989 23520000
         N     2,=F'-8'                                            5989 23530000
         N     3,=F'-8'       ROUND SVI TO A DOUBLE-WORD BOUNDARY  5989 23540000
         SR    3,2            GET THE LENGTH OF THE GARBAGE AREA   5989 23550000
         LH    2,MVCLNGTH     GET THE LENGTH OF THE MOVE           5989 23560000
         LPR   2,2            MAKE IT POSITIVE                     5989 23570000
         CR    3,2            WAS THE MOVE DESTRUCTIVE ?           5989 23580000
         BNL   SELNOR2        NO, MOVE BACK NOT NECESSARY          5989 23590000
*                                                                  5989 23600000
*        FIX UP THE DAMAGED WS                                     5989 23610000
*                                                                  5989 23620000
         L     7,=A(REMCDC)   ESTABLISH ADDRESSABILITY             5989 23630000
         USING REMCDC,7       FOR REMCDC CODE                      5989 23640000
         BAL   0,MVCREV       GO MOVE THE DATA BACK                5989 23650000
         DROP  7                                                   5989 23660000
SELNOR2  EQU   *                                                   5989 23670000
         LH    2,CDOP-1                                                 23680000
         MVI   SELBUSY,0           MARK IDLE                            23700000
         LH    10,CDZTAB(2)        GET INTERRUPT SUBROUTINE ADDRESS     23740000
         DEREL   ,                 DELATIVIZE                           23750000
         BALR  LINK,10             COROUTINE TYPE LINKAGE               23760000
         SELEXIT                   ,RETURN FROM SELINTERRUPT            23770000
CDZTAB   DCY   RSELSUB             0 NORMAL WRITE                       23790000
         DCY   SELRDZ              2 NORMAL READ                        23800000
         DCY   SELDRZ              4 DIRECTORY READ                     23810000
         DCY   WWZSAVE             6 SAVE, WORKSPACE WRITE              23820000
         DCY   DIR3RD              8 AFTER WRITE OF ALT DIRECTORY       23830000
         DCY   SELLDZ              10 LOAD COPY, WORKSPACE READ         23840000
         DCY   DIR4TH              12 AFTER DIR3RD DIRECTORY READ       23850000
         DCY   DIR2ND              14 DIRECTORY WRITE, PRIMARY COPY     23860000
         DCY   SELWSK              16 COPKILL GLITCH                    23870000
*                                                                       24220000
         SELEXCP                                                        24230000
*                                                                       24240000
*                                                                       24250000
*                                                                       24260000
*                                                                       24270000
*        R0 IS CAW SETTING, R1 IS DEVICE ADDRESS                        24280000
*        TYPICAL CALL                                                   24290000
*        L     0,CAW SETTING                                            24300000
*        BAL   5,SIOSUB                                                 24310000
*        B     STARTED             SIO WITH CC ZERO                     24320000
*        STATUS STORED                                                  24330000
SIOSUB   ST    0,CAW                                                    24340000
         MVC   CSW,ZERO            CLEAR CSW                            24350000
         BAL   3,IODADV           RECORD CAW AND STATUS                 24360000
         USING IODBUG,2                                                 24370000
         MVC   IODCAW(4),CAW                                            24380000
         MVI   IODSIO,X'FF'       MARK AS SIO                           24390000
SIO2     SIO   0(1)                                                     24400000
*        IO STARTED WITH ZERO STATUS                                    24410000
SIO4     BCR   8,5                 RETURN TO CALLER                     24420000
         BC    2,SIO2              TRY AGAIN IF BUSY                    24430000
         BC    4,SIO5              STATUS STORED                        24440000
*        DEVICE NOT OPERATIONAL  (SELECT IN RETURNED)                   24450000
*        ASSUME TRANSIENT ERROR ON BUS OUT                              24460000
         SIO   0(1)                                                     24470000
         BC    14,SIO4             SUCCESS                              24480000
*        TWICE IN A ROW                                                 24490000
DEVDEAD  MVC   CSW+3(2),=AL2(265+UC) FORCE ENTRY TO UC ROUTINE          24500000
         OC    IODDSCS-1(3),CSW+3                                       24510000
         B     4(5)                INDICATE ERROR                       24520000
*        STATUS RETURNED                                                24530000
SIO5     CLI   CSW+4,CUB2702                                            24540000
*        CHECK TO SEE IF STATUS IS 2702 CU BUSY                         24550000
         MVC   IODDSCS,CSW+4      STATUS BYTES                          24560000
         BE    SIO2                YES, KEEP TRYING                     24570000
         TM    CSW+4,BSY+CE                                             24580000
         BC    12,4(5)             ANALYZE STATUS                       24590000
*        BUSY AND CHANNEL END, SCHEDULING ERROR                         24600000
*        DEVICE WAS REALLY BUSY, THIS IS SUPERVISOR ERROR               24610000
         UGH   ,                   WORKSPACE MUST BE ON DISK            24620000
         DROP  2                                                        24630000
         EJECT                                                          24640000
*                                                                       24650000
*        MAINTAIN BUFFER OF OLD IO STATUS INFO                          24660000
*        THIS SUBROUTINE IS NOT REENTRANT  * * * * * * *                24670000
*                                                                       24680000
IODBUG   DSECT                                                          24690000
*                                                                       24700000
*        I/O INTERRUPT ENTRY                                            24710000
*                                                                       24720000
IODUNAD  DS    H X'0CUU'           DEVICE ADDRESS                       24730000
IODCSW   DS    0DL8                CSW ON INTERRUPT                     24740000
         DS    X                   SENSE BYTE (MPX SENSING ONLY)        24750000
         DS    AL3                 COMMAND ADDRESS                      24760000
         DS    H                   STATUS                               24770000
         DS    H                   RESIDUE BYTE COUNT                   24780000
*                                                                       24790000
*        SIO ENTRY                                                      24800000
*                                                                       24810000
         ORG   IODBUG                                                   24820000
         DS    H X'0CUU'           DEVICE ADDRESS                       24830000
IODCAW   DS    FL4                 CAW                                  24840000
IODDSCS  DS    H                   STATUS BYTES                         24850000
IODSIO   DC    X'FF'               SIO FLAG                             24860000
         DC    X'00'                                                    24870000
*                                                                       24880000
*        DISK ERROR ENTRY                                               24890000
*                                                                       24900000
         ORG   IODBUG                                                   24910000
IODCDOP  DS    H X'OCUU'           OPERATION & DEVICE ADDRESS           24920000
IODSENSE DS    0DL8                                                     24930000
         DS    FL4                 SENSE DATA                           24940000
         DS    HL2                 CC OF SEEK ADDRESS              DASD 24950000
         DC    X'FE'               DISK ERROR CODE                      24960000
         DC    X'0'                H OF SEEK ADDRESS               DASD 24970000
*                                                                       24980000
*        IEMPX ENTRY                                                    24990000
*                                                                       25000000
         ORG   IODBUG                                                   25010000
         DS    H X'0CUU'           DEVICE ADDRESS                       25020000
IODCCB   DS    FL4                 PUCCB                                25030000
IODTYPE  DS    H                   PTTYPE & STATE                       25040000
IODIE    DC    X'FD'               IEMPX FLAG                           25050000
         DC    X'00'                                                    25060000
*                                                                       25070000
*        HIO ENTRY                                                      25080000
*                                                                       25090000
         ORG   IODBUG                                                   25100000
         DS    H X'0CUU'           DEVICE ADDRESS                       25110000
         DS    DL8                 CSW                                  25120000
         ORG   IODCSW+6                                                 25130000
IODHIO   DC    X'FC'               HIO FLAG                             25140000
*                                                                       25150000
APLSUP   CSECT                                                          25160000
*                                                                       25170000
         USING IODBUG,2                                                 25180000
IODADV   L     2,IODCON                                                 25190000
         LA    2,10(2)            ENTRY LENGTH                          25200000
         C     2,IODCON+8                                               25210000
         BL    *+8                                                      25220000
         L     2,IODCON+4         BUFFER WRAPAROUND                     25230000
         STH   1,IODTRASH          SIFT OUT DESIRED CHANNEL/CU/DEVICE   25240000
         NC    IODTRASH(2),IODSIFT ENTRIES AND IGNORE OTHERS            25250000
         CLC   IODTRASH(2),IODSIFT+2                                    25260000
         BE    *+10                                                     25270000
         LA    2,IODTRASH          CALL REJECTED, PROVIDE TRASH AREA    25280000
         BR    3                                                        25290000
         ST    2,IODCON                                                 25300000
         MVC   IODCSW,CSW                                               25310000
         STH   1,IODUNAD                                                25320000
         BR    3                                                        25330000
         DROP  2                                                        25340000
*                                                                       25350000
         ENTRY IODCON              IODCON REFERENCED BY EXMHIST         25360000
IODCON   DC    A(IODBUGG,IODBUGG,IODBUGZ)  IODADV PARAMETERS            25370000
*                INDEX    START    END                                  25380000
IODSIFT  DC    H'0'                MASK OF PART OF IO ADDR TO COMPARE   25390000
         DC    H'0'                IO ADDRESS TO COMPARE FOR            25400000
IODTRASH DC    5H'0'               DUMMY IODBUG AREA                    25410000
         EXTRN IODBUGG,IODBUGZ     IODEBUG TABLE IS ASSEMBLED INTO      25420000
*                                  APLSCONF FOR FLEXIBILITY.            25430000
*                                                                       25440000
*        SENSE BYTE ANALYSIS                                            25450000
*  TUSCH IS REENTRANT                                                   25460000
*        R2 IS SENSE BYTE FOR ANALYSIS                                  25470000
*        TABLES ARE FROM TUSGEN MACRO                                   25480000
         USING PERDEVX,PXR                                              25490000
TUSCH    SR    0,0                                                      25500000
         L     1,PXSENC                                                 25510000
         IC    0,PXSENC                                                 25520000
         SR    SIGR,SIGR         UNRECOGNIZED, ASSUME NORMAL END        25530000
UCB1     EX    2,UCB3             EXAMINE SENSE MASKS                   25540000
         BC    7,UCB2            DESIRED CONDITION                      25550000
         LA    1,1(1)             TRY NEXT BYTE                         25560000
         BCT   0,UCB1                                                   25570000
         BR    LINK                                                     25580000
UCB2     IC    SIGR,TUSSL(1)     GET SIGNAL BYTE                        25590000
*        SIGNAL BYTE HAS BEEN PLACED IN SIGR                            25600000
         BR    LINK               AND DELIVER                           25610000
UCB3     TM    0(1),0             SUBJECT OF EXECUTE                    25620000
         DROP  PXR                                                      25630000
*                                                                       25640000
*        SENSE DATA ROUTINE FOR ANY CHANNEL                             25650000
*        SUBROUTINE TO DO SENSE IO FOR MPX                              25660000
*        GETSEN EXPECTS CAW SETTING IN R0,UNIT ADDRESS IN R1            25670000
GETSEN   BAL   5,SIOSUB                                                 25680000
         B     4(LINK)                                                  25700000
*        STATUS RETURNED FROM SIO WITH SENSE IO COMMAND                 25750000
         TM    CSW+4,BSY+DE                                             25760000
         BO    GETSEN                                                   25770000
*        NOTES ON PRECEDING INSTRUCTION.  CODE AT SIO5 HAS CHECKED FOR  25780000
* CHANNEL END ABSENT.  IT IS ASSUMED THAT THE STATUS OF 'BUSY,DE,UC'    25790000
* WAS PRECEDED BY AN INTERRUPT WITH 'CE,UC'.                            25800000
         CLI   CSW+4,SM+BSY        CONTROL UNIT BUSY                    25810000
         BE    GETSEN              ASSUME 2314 FAULT                    25820000
*                                                                       25830000
*        SIO STATUS DOES NOT CONTAIN BUSY BIT.                          25840000
         BR    LINK                ASSUME BUS OUT CHECK                 25850000
         EJECT                                                          26000000
*              DIRECTORY READ END                                       26010000
*        LINK= SELEXIT                                                  26030000
SELDRZ   BAL   6,MAKCYL            GUARANTEE EXISTENCE OF EMPTY CYLINDR 26040000
SDSWRSET EQU   *                   FOLLOWING MVC IS EXECUTED            26050000
         MVC   SDQZSW(8),QZNOP     RESET SDQZSW & RSELSW                26060000
         BAL   6,RELOCT            RELOCATE AND SET MPTBASE             26070000
         USING M,5                                                      26080000
         CLI   SDOP,XXLEMP                                              26090000
         BE    SELDRZ1            SIGN ON IS SPECIAL CASE               26100000
         MVC   SDQZSW,=A(EXECDSER)   DO HOUSEKEEPING AT QUEND           26110000
*        PERTERM, PERCORE HOUSEKEEPING WILL BE DONE BY EXECDSER         26120000
         B     RINGSUB             TERMINATE QUANTUM                    26130000
*                                                                       26140000
*        SIGN-ON OR LOAD-EMPTY                                          26150000
SELDRZ1  LM    1,2,CDTERM         PREPARE TO SCAN SIGNON MESSAGE        26160000
         USING PERTERM,1                                                26170000
         USING PERCORE,2                                                26180000
         ST    2,PTCORE                                                 26190000
         MVC   PCTERM+1(3),CDTERM+1                                     26200000
         EXTRN TYPEIN                                                   26210000
         MVC   FRSAVE+36(4),=A(TYPEIN)  TO PROCESS SIGN-ON MESSAGE      26220000
         MVI   ACTIVE,ATTENM+NONINM   ASSUME SIGN ON                    26230000
         PTSET ACTIVE                                                   26240000
*        ATTENM AND NSIGNM WILL RESET NONINM AT SVTYI3 TO DELIVER       26250000
*        INPUT (HOPEFULLY SIGNON COMMAND) AT STYIZ                      26260000
         TM    IOB1,NSIGNM         SIGN ON VS. LOAD EMPTY WORKSPACE     26270000
         BO    SELDRZ2             SIGNON                               26280000
         EXTRN NEWWS                                                    26290000
         MVC   FRSAVE+36(4),=A(NEWWS)   PRINT MESSAGE                   26300000
         LA    0,FREE-M(0)         LOAD EMPTY OP, LOSE DIRECTORY        26310000
         ST    0,MX                                                     26320000
         MVI   ACTIVE,NONINM       NORMAL SETTING                       26330000
         PTSET ACTIVE                                                   26340000
SELDRZ2  MVI   MISCB,0                                                  26350000
         PTSET MISCB                                                    26360000
         B     SDKILLA             TERMINATE SPECIAL DISK OPERATION     26370000
         DROP  1,2                                                      26380000
*                                                                       26390000
*                                                                       26400000
*        LOAD, COPY END OF READ FROM LIBRARY OF SAVED WORKSPACE         26410000
SELLDZ   MVI   CDCBASE+1,EMPTYM    FORCE PROG CK IF NOT SET BEFORE USE  26420000
         EXTRN SDRET                                                    26430000
         L     5,CCPAR1            BASE FOR FOLLOWING INSTRUCTION.      26440000
         MVC   FRSAVE+36(4),=A(SDRET)   RETURN FROM SPECIAL DISK        26450000
         BAL   6,RELOCT            RELOCATE AND SET MPTBASE             26460000
         DROP  5                                                        26470000
RZX3     LM    1,3,CDDISK          END OF DISK READ                     26480000
         USING PERDISK,1                                                26490000
         USING PERTERM,2                                                26500000
         USING PERCORE,3                                                26510000
         MVC   PCTERM+1(3),PDTERM+1                                     26520000
         MVC   PCQUONT,ZERO                                             26530000
         MVI   PDTERM+1,EMPTYM                                          26540000
         ST    3,PTCORE            FOR UNRZ3 AND SPECIAL DISK           26550000
         DROP  1,2,3                                                    26560000
RINGSUB  L     1,CURRENTM          SIGNAL INTRP QUANTUM END DESIRED     26580000
         C     1,=A(SCHSAVE)       BUT DON'T SIGNAL SCHEDULER      P062 26590000
         BCR   8,LINK                                              P062 26600000
         MVC   MQCELL-M(4,1),QZSVC                                      26610000
         BR    LINK                                                     26620000
*                                                                       26630000
*        NORMAL WORKSPACE READ COMPLETION                               26650000
SELRDZ   BAL   6,RELOC             RELOCATE STACK AND REGISTERS         26660000
*        TRY TO CONTRACT CURRENTLY USED DISK REGION                     26670000
*        R1 = MAXARM, R2 = ARM, R3 = FIRST CYLINDER                     26680000
         LM    0,3,PDBXLE                                               26690000
         CLR   1,2                 TEST ARM=MAXARM                      26700000
         BNE   RZX3                                                     26710000
         SR    1,0                                                      26720000
         CLI   PDTERM+1-PERDISK(3),EMPTYM                               26730000
         BC    8,RZX2              FOUND AN INTERIOR HOLE               26740000
         BXLE  3,0,*-8                                                  26750000
         B     RZX3                NO INTERIOR HOLE                     26760000
RZX2     ST    3,ARM               MOVE HYPOTHETICAL ARM                26770000
         LCR   2,0                  CHANGE HOLE SEARCH DIRECTION        26780000
         AR    1,0                 START 1 SLOT HIGH                    26790000
         CLI   PDTERM+1-PERDISK(1),EMPTYM                               26800000
         BNE   *+8               NOT EMPTY, STOP SCAN                   26810000
         BXH   1,2,*-8                                                  26820000
         ST    1,MAXARM            NEW LIMIT OF DISC REGION             26830000
         B     RZX3                SET POINTERS                         26840000
*                                                                       26850000
*                                                                       26860000
*                                                                       26870000
         PRINT GEN                                                      26880000
DUMMY    DSECT                                                          26890000
*        SAMPLE CALL OF LINKAGE MACROS                                  26900000
*                                                                       26910000
         PROLOG                                                         26920000
*                                                                       26930000
         PROLOG LOCAL,LOCALZ                                            26940000
*                                                                       26950000
         ICALL UNRZ                                                     26960000
*                                                                       26970000
         IRETURN                                                        26980000
*                                                                       26990000
LOCAL    DSECT ,                   SAMPLE R13 STACK DSECT               27000000
LOCALA   DS    D                                                        27010000
LOCALB   DS    F                                                        27020000
LOCALZ   EQU   *                                                        27030000
*                                                                       27040000
         DROP  PR,LR                                                    27050000
*                                                                       27060000
APLSUP   CSECT                                                          27070000
*        ASSUMPTIONS ABOUT PROLOG MACRO  ============================   27080000
*        LR AND TLR ARE ADJACENT                                        27090000
*        LR IS BACKWARD LINK                                            27100000
*        SAVED LR OF OUTERMOST LEVEL IS ZERO                            27110000
*        RELOCATE WORK SPACE, R6 IS RETURN                              27120000
         USING M,5                                                      27130000
*        RELOCT IS USED FOR NEW WORKSPACES FROM LOAD, COPY, DIRECTORY   27140000
RELOCT   L     5,CCPAR1                                                 27150000
         MVC   MPTBASE,CDTERM                                           27160000
         MVI   MPTBASE,0                                                27170000
RELOC    L     1,CCPAR1       WORKSPACE ADDRESS                    5989 27180000
         CLI   ONETRK,INCORMV      IS A MOVE NECESSARY?            5989 27190000
         MVI   ONETRK,NOT1TRK      RESET THE SWITCH                5989 27200000
         BH    SVMV2               NO MOVE REQUIRED                5989 27210000
         L     7,=A(REMCDC)   ESTABLISH ADDRESSABILITY             5989 27220000
         USING REMCDC,7       FOR REMCDC CODE                      5989 27230000
         BAL   0,MVCREV       GO MOVE THE DATA BACK                5989 27240000
         DROP  7                                                   5989 27250000
SVMV2    L     4,CCPAR1       WORKSPACE ADDRESS                    5989 27260000
         LR    5,4                                                 5989 27270000
         S     4,MEMAD        PREVIOUS CORE ADDRESS                5989 27300000
         LR    0,5                                                      27310000
         A     0,WLEN              TOP OF THIS WORKSPACE                27320000
         LA    1,M+4*12                                                 27330000
         B     STMV2                                                    27340000
STMV1    STM   2,3,4(1)            UPDATE SAVED R13,R14                 27350000
STMV8    LR    1,2                                                      27360000
STMV2    LM    2,3,4(1)            R13,R14                              27370000
         AR    3,4                                                      27380000
         LTR   2,2                 VALIDATE R13                         27390000
         BZ    STMV5               NEW R13 ZERO -- END OF LIST          27400000
         BM    STMV3               NEW R13 NEGATIVE -- ERROR            27410000
         AR    2,4                 RELOCATE BY (NEW M) - (OLD M)        27420000
         CLR   2,0                                                      27430000
         BNL   STMV3               NEW R13  GEQ  NEWMR+WLEN             27440000
         EX    2,STMV4             CLI =X'03',0                         27450000
         BZ    STMV1               ZERO = 4 REMAINDER NEW MR            27460000
*        R13 IS INVALID                                                 27470000
STMV3    MVC   M+4*LR(8),ZERO      CLEAR R13,R14                        27480000
         EXTRN EREXSUP    ROUTINE TO PRINT ERROR MESSAGE AND CALL TYPIN 27490000
         MVC   FRSAVE+36(4),=A(EREXSUP)                                 27500000
         B     STMV6               CONTINUE                             27510000
STMV4    TM    =X'03',0            TEST FOR DIVISIBILITY BY FOUR        27520000
*        END OF RELOCATION LOOP                                         27530000
STMV5    ST    3,8(1)              RELOCATED R14                        27540000
STMV6    ST    5,MEMAD             FOR USE NEXT TIME THIS WORKSPACE IS  27550000
*              PROCESSED BY THE PRECEDING LOOP                          27560000
*        SET   PSW STORAGE KEY                                          27570000
         SR    1,1                                                      27580000
         IC    1,ACTKEY                                                 27590000
         EX    1,STMV7             OR ACTIVE KEY WITH MP BITS           27600000
         MVI   FRSAVE+32,X'FF'     SYSTEM MASK                          27610000
         DC    0AL4(ALLON)                                         DASD 27620000
         BR    6                                                        27630000
STMV7    MVI   FRSAVE+32+1,X'05'   AMWP = MP                            27640000
         DROP  5                                                        27650000
*        READ SELECT                                                    27660000
*        EMPTY SLOT EXISTS IN CORE                                      27670000
*        FIND A WORKSPACE ON DISK TO READ                               27680000
         USING PERDISK,2                                                27690000
         USING PERTERM,3                                                27700000
RSDIR2   EX    0,SDSWRSET          RESET SDQZSW & RSELSW                27710000
         LR    5,LINK              LINK IS RETURN FOR RSELSUB TOO       27720000
         BAL   LINK,SDKILLA        SELECT ANOTHER LEMP TERMINAL MAYBE   27730000
         LR    LINK,5              DO SOME DISK READ                    27740000
RSELSUB  EQU   *                                                        27750000
         L     1,RSELSW                                                 27760000
         BR    1                  EITHER RSEL0  OR  RSDIR               27770000
*        READ SELECT OF DIRECTORY                                       27780000
RSDIR    MVI   CDOP,4              SELDRZ AT SEL INTERRUPT              27790000
         L     3,SDT                                                    27800000
         L     5,ASDPAR            FROM THE LIBRARY NUMBER IN COMMAND   27810000
         L     5,PDSLIB-PDSDDDD(5)                                      27820000
         CLI   SDOP,XXLEMP                                              27830000
         BNE   RSDIR1                                                   27840000
         LH    5,PTCORE+2          PARAMETER FROM SVLEMP                27850000
         TM    MISCB,WANTON        IF OFFSUB WAS EXECUTED ON A MPX INTR 27860000
         BZ    RSDIR2              SDOP STARTED AT LEMP OR SDK3),  WE   27870000
*                                  RECOVER BY KILLING THIS SPECIAL DISK 27880000
*                                  OP AND GOING TO START OF RSELSUB     27890000
RSDIR1   SR    4,4                                                      27900000
         D     4,KMHASH            GET DESIRED DIRECTORY NUMBER         27910000
         SLL   4,3                 GET DISK ADDRESS OF PRIM AND ALT     27920000
         A     4,ADIRTAB           DIRECTORIES FOR THIS DIR READ        27930000
         MVC   DIRCYL(8),0(4)      DIRECTORY AND ALTERNATE         DASD 27940000
         MVC   PHYCYL(4),DIRCYL                                    DASD 27950000
         LA    2,SDT+PERDISK-PDTERM  ADDR OF DUMMY PERDISK              27960000
         MVC   CDCBASE,LIBBASE     CHANGE TO LIBRARY DISK               27970000
         NI    MISCB,255-NOWSM       FOR WSLOSEC                        27980000
         B     RSELSTAR                                                 27990000
RSEL0    LA    4,2                                                      28000000
         LM    0,2,PDBXLE                                               28010000
RSEL3    BXLE  2,0,RSEL2                                                28020000
*        UNSUCCESSFUL SEARCH                                            28030000
*        END OF SWEEP, CHANGE READ SELECT ALGORITHM                     28040000
         LH    3,ALG1                                                   28050000
         LTR   3,3                                                      28060000
         BL    RSEL5                                                    28070000
         SH    3,ALG1+2                                                 28080000
         MVI   RSEL1+1,ACTIVEM        PROG MODIFICATION   $$$$$$$       28090000
         BCT   4,RSEL6             PREVENT INFINITE LOOP                28100000
         BAL   6,MAKCYL            ARM MUST POINT TO EMPTY CYLINDER     28110000
         BR    LINK                                                     28120000
RSEL5    AH    3,ALG1+4            ALG1 LESS THAN 0 CASE                28130000
         MVI   RSEL1+1,ACTIVEM+NONINM   PROG MODIFICATION   $$$$$$$$$$  28140000
RSEL6    STH   3,ALG1                                                   28150000
         L     2,ARM+4           RESET ARM AND RESCAN                   28160000
RSEL2    CLI   PDTERM+1,EMPTYM                                          28170000
         BE    RSEL7              EMPTY CYLINDER                        28180000
         L     3,PDTERM                                                 28190000
RSEL1    TM    ACTIVE,ACTIVEM      MASK IS ALTERED   $$$$$$$$$$$$$$$$$  28200000
         BC    7,RSEL3                                                  28210000
*        MOVE THIS WORKSPACE TO CORE                                    28220000
         ST    2,ARM               READ FROM THIS CYLINDER.             28230000
         BAL   4,FINDSWAP          SET UP DISK ADDRESS                  28240000
         MVI   CDOP,2              FOR SELNOR SWITCH                    28250000
RSELSTAR STM   2,3,CDDISK                                               28260000
         MVI   DOP+1,X'06'          READ DATA  PROG MOD   $$$$$$$$$$$$$ 28270000
         USING CDCPARS,4                                           5989 28280000
         L     4,CDCBASE                                           5989 28290000
         TM    CDCFLAGS,CDCNDC     MAY WE DATA CHAIN               5989 28300000
         BO    RSELDCN             NO                              5989 28310000
         MVC   CDCAD+4(4),SELARGDC RESET CDCAD TO DATA CHAIN       5989 28320000
         L     0,CDCAD                                                  28330000
         AH    0,CDCAD+6                                                28340000
         ST    0,CDCAD+8           DC ADDRESS                           28350000
         L     0,TLENF             SETUP FIRST TRACK READ               28360000
         SH    0,CDCAD+6                                                28370000
         STH   0,CDCAD+6+8         TRMAX-SELARGL                        28380000
DRP4     MVI   RD1A,0              FORCE CHANNEL PROG CHECK             28390000
         L     3,RD1ST                                                  28400000
         MVC   2(4,3),PHYCYL       SETUP CCHH FOR SEEK, SCHIDEQ    DASD 28410000
         MVI   RPSCCW,NOP          RESET TO NO OP COMMAND          DASD 28430000
         TM    CDCFLAGS,RPS        SHOULD SET SECTOR BE USED       DASD 28440000
         BZ    DRP5                NO                              DASD 28450000
         MVI   RPSCCW,SETSECTR     MOVE IN SET SECTOR COMMAND      DASD 28460000
DRP5     EQU   *                                                   DASD 28470000
         DROP  4                                                   DASD 28490000
         LA    0,RD1ST             CAW SETTING                          28500000
         B     SELEXCP             ISSUE START IO                       28510000
         USING CDCPARS,4                                           5989 28520000
RSELDCN  MVC   CDCAD+4(4),TLENF    READ THE WHOLE FIRST RECORD     5989 28530000
         MVC   EXPCSW(8),NDCCSW    EXPECT NORMAL END AFTER 1 TRACK 5989 28540000
         B     DRP4                GO FINISH SET-UP AND START IT   5989 28550000
         DROP  4                                                   5989 28560000
RSEL7    BXLE  2,0,RSEL2                                                28570000
*        MAXARM POINTS TO AN EMPTY WORKSPACE                            28580000
         SR    1,0                                                      28590000
         ST    1,MAXARM                                                 28600000
         B     RSEL3                                                    28610000
         DROP  2,3                                                      28620000
*                                                                       28630000
*        MAKE CERTAIN AN EMPTY CYLINDER EXISTS ON DISK                  28640000
MAKCYL   LM    0,3,PDBXLE                                               28650000
         LR    2,3                 ARM IS MINARM                        28660000
MAKC2    CLI   PDTERM+1-PERDISK(2),EMPTYM                               28670000
         BE    MAKC1              FOUND AN EMPTY CYLINDER               28680000
         BXLE  2,0,MAKC2                                                28690000
         LR    1,2                NEW MAXARM VALUE                      28700000
MAKC1    STM   1,2,MAXARM         ARM NOW POINTS TO EMPTY CYL           28710000
         BR    6                                                        28720000
*                                                                       28730000
*        LOCATE SWAPPARS AND SET UP SEEK ADDRESS                        28740000
         USING PERDISK,2                                                28750000
FINDSWAP SR    0,0                                                      28760000
         IC    0,PDXTENT           PICK UP SWAP EXTENT INDEX            28770000
         A     0,SWAPBASE          ADD START OF SWAP TABLE              28780000
         ST    0,CDCBASE           SAVE FOR FUTURE REFERENCE            28790000
         MVC   PHYCYL,PDDA         CYLINDER,HEAD (CCHH)            DASD 28800000
         BR    4                   RETURN                               28810000
         DROP  2                                                        28820000
*                                                                       28830000
*                                                                       28850000
*        CDCOMP                                                         28870000
         USING PERCORE,5                                                28880000
         USING PERDISK,4                                                28890000
CDCOMPW  MVI   PCTERM+1,EMPTYM    MARK CORE SLOT EMPTY                  28900000
         LR    2,4                 PERDISK ADDRESS                      28910000
         BAL   4,FINDSWAP          SET UP DISK ADDRESS                  28920000
         DROP  4                                                        28930000
         MVI   CDOP,0             WRITE OPERATION                       28940000
CDCOMPS  MVI   DOP+1,X'05'      SAVE ENTRY POINT,   PROG MODIFICATIO$$$ 28950000
         NI    CCFIRST,0           SET FIRST WRITE PASS SWITCH     DASD 28970000
         MVC   CDCAD+1(3),PCADDR   ACTUAL CORE ADDRESS                  28990000
         DROP  5                                                        29000000
CDCOMP2  LA    6,SELEXCP           EXIT VIA SIO SUBROUTINE              29010000
CDCOMP   STM   6,7,CDSAVE                                          DASD 29030000
         L     7,=A(REMCDC)                                        DASD 29040000
         BALR  6,7                                                 DASD 29050000
         LM    6,7,CDSAVE                                          DASD 29060000
         BR    6                                                   DASD 29070000
         COPY  CDINF                                               DASD 29080000
RDHA     EQU   X'1A'               READ HOME ADDRESS                    29090000
*        SCHEDULER SWITCHES SET BY SPECIAL DISK ROUTINES                29100000
OPNUM    DC    X'FF'               NUMBER OF OPERATOR'S TERMINAL        29120000
DELZFLG  DC    X'00'               CONTROLS MPXEXIT                     29140000
SHUTDOWN DC    X'00'               ONE=SYSTEM SHUT DOWN IN PROGRESS     29150000
SWITCHES DC    AL1(QZSW1)     ASSORTED SWITCHES                    C022 29160000
QZSW1    EQU   X'01'          SEE SVTYI AND QUEND                  C022 29170000
SELAPENT EQU   X'02'               APPENDAGE ENTRY SWITCH          DASD 29180000
RESCH    DC    X'00'                                               3064 29190000
POSO     DC    F'0'                PLUS OVER SIGNED ON                  29250000
FSHARE   DC    F'10'               FAIR SHARE OF TYPEWRITER BUFFERS     29260000
         ENTRY COPSINK             REFERENCED BY PCSB              2550 29270000
COPSINK  DC    A(EMPT3)            COPY SINK PERTERM ADDRESS            29280000
COPSOUR  DC    A(AUXTERM)          COPY SOURCE PERTERM                  29290000
SSKALGN  DC    X'00FFF800'         TO ALIGN SSK TARGET.                 29300000
ASDPAR   DC    A(SDPAR)            POINTER TO GENUINE PDSDDDD           29320000
         EXTRN SDPAR               DEFINED IN DIRECTORY SEARCH          29330000
         EXTRN AUXTERM                                                  29350000
OPTERM   DC    A(AUXTERM)          AUXILIARY TERMINAL IS NEVER SIGNEDON 29360000
SDQZSW   DC    A(QZD0)             QUANTUM END WITH SEL CHAN IDLE       29380000
RSELSW   DC    A(RSEL0)            READ SELECTION SUBROUTINE            29390000
GETDIR   DC    A(MAKHOL,RSDIR)   SWITCH SETTINGS TO READ DIRECTORY      29400000
*        NORMAL SETTINGS FOR SCHEDULER SPECIAL DISK SWITCHES            29410000
QZNOP    DC    A(QZD0)                                                  29420000
RSELNOP  DC    A(RSEL0)                                                 29430000
SDT      DC    A(EMPT3,0,SWAPPARS)   TERMINAL DOING SPECIAL DISK OP     29440000
HDCORE   EQU   SDT+4          TEMP STORE OF PTCORE(SDT) DURING SD OP    29450000
CDCBASE  EQU   HDCORE+4            CDCPARS BASE REG, APLSUP & DIRSEAR   29460000
         EXTRN DIRTAB                                                   29470000
ADIRTAB  DC    A(DIRTAB)           TABLE OF DIRECTORY DISK ADDRESSES    29480000
*                                                                       29510000
*                                                                       29520000
LIBNOW   DC    H'0'                NUMBERS OF )LIB'S IN PROGRESS        29530000
LIBLIM   EQU   COPLIM                                                   29540000
         DC    X'00'               HIGH-ORDER BYTE OF SDOP HALFWORD     29550000
SDOP     DC    C'*'                CURRENT SPECIAL DISK OPERATION       29560000
QZSVC    SVCC  YYQZ                                                     29580000
NOPR     BCR   0,0                                                      29590000
DUMY     DC    AL1(ACTIVEM,0,0)    THOROUGH SUSPENSION                  29640000
         ENTRY EXINTLK                                             C022 29660000
EXINTLK  DC    X'00'          INTERLOCK WITH  T.C.E.R.             C022 29670000
DSZEXIT  DC    A(*-*)                                                   29690000
KX24M    DC    X'00FFFFFF'         CLEAR HIGH ORDER BYTE                29700000
ZERO     DC    2F'0'               DSZON REQUIRES EIGHT BYTES           29710000
CDSAVE   DS    2F                  R6 AND R7 DURING REMCDC         DASD 29720000
DUMINACT EQU   DUMY+PERTERM-ACTIVE DUMINACT IS USED AS A PERTERM        29730000
*              SIGNED OFF.  NOBODY SETS BITS IN IOB1(DUMINACT) SO OKAY. 29740000
*              AREA DURING LIBRARY DIRECTORY PRINTING.  ALL GENUINE     29750000
*              WORKSPACES WHICH HAVE BEEN STASHED ON DISK FOR LIB       29760000
*              PRINT HAVE PDTERM = DUMINACT.                            29770000
************** DUMINACT MUST BE 16 BEFORE AL1(ACTIVEM)  **************  29780000
IESW     DC    X'00'               PROCRASTINATE SETTING TIMER          29790000
FSWAP    DC    X'00'               UNRZ TO SCHED COMMUNICATION          29810000
*        FSWAP OFTEN AVOIDS NECESSITY TO COMPUTE  AND/NONINM.  FSWAP    29820000
*        ALSO HAS THE EFFECT OF PROLONGING THE WINDOW CREATED BY        29830000
*        HSCNT OVERFLOWING.                                             29840000
ALG1     DC    H'1,1,1'            CONTROLS DISK READ SELECTION ALGOR   29850000
DIRSMAN  DC    F'0',5H'0'          RESULT OF DIRECTORY SEARCH           29860000
DIRSRES  EQU   DIRSMAN+4                                                29870000
DSFILE   EQU   DIRSRES+4           PACK FOR WS READ OR WRITE            29880000
DIRSWSQ  EQU   DIRSRES+6           WSQ, WSA FOR DIR4TH                  29890000
DIRCHANG DC    X'00'               DIRSRES + 10                    DASD 29900000
         SPACE 2                                                   3064 29920000
*  SETHILO  SWITCH/FLAGS  FOR APLSETHI/APLSETLO                    3064 29930000
*                                                                  3064 29940000
SHLFLAGS DC    AL1(SHLACTIV+SHLCUR) APLSETHI/APLSETLO STATUS       3064 29950000
SETHILO  EQU   SHLFLAGS            PSEUDONYM                       3064 29960000
         SPACE 1                                                   3064 29970000
SHLACTIV EQU   B'00000010'    1 - SETHI/SETLO LOOP IS ACTIVE       3064 29980000
*                             0 - SETHI/SETLO LOOP IS STOPPED      3064 29990000
SHLCUR   EQU   B'00000001'    1 - APL CURRENTLY AT HIGH PRIORITY   3064 30000000
*                             0 - APL CURRENTLY AT LOW  PRIORITY   3064 30010000
SHLSTOPH EQU   B'00110000'    STOP LOOP AT HIGH PRIORITY           3064 30020000
         SPACE 1                                                   3064 30030000
*RESERVED      B'X...XX..'    RESERVED                             3064 30040000
         SPACE 2                                                   3064 30050000
QZPRG    DC    F'0'           EVENT TO PURGE AT QUANTUM END             30070000
QUANLIM  IEBRN SETBELL,MAXQUAN                                          30080000
PANLIM   IEBRN SETPAN,PANICINT                                          30090000
         EXTRN FREE3          CSECT IN CONFIG                           30130000
IEHED    DC    A(FREE3+12)                                              30140000
HD3FR    DC    A(FREE3)            INITIALLY IT HAS ONE ELEMENT         30150000
         EXTRN LIBPARS                                                  30170000
         EXTRN SWAPPARS                                                 30180000
*        SWAPBASE AND LIBBASE POINT TO CDCPARS DSECT                    30190000
LIBBASE  DC    A(LIBPARS)                                               30200000
SWAPBASE DC    A(SWAPPARS)                                              30210000
TTERM    DC    F'0'                USED TO MEASURE COMPUTE TIME         30270000
MXTEM12  DS    3F                                                       30280000
*        DOUBLE WORD ALIGNMENT AREA   *************                     30290000
NOPCSW   DC    A(RD1A+8,X'0C00'*X'10000'+1)                             30310000
MXOLDPSW DS    1D                  COPY OF IOOLDPSW                     30330000
MPXCSW   DS    1D                                                       30340000
TIMEHI   DC    F'0'          CPU TIMER VALUE AT LAST CHAP REQUEST  3064 30360000
         ENTRY SVINT                                                    30370000
         ENTRY SVOLDPSW                                                 30380000
         ENTRY EXOLDPSW            FOR MVT MOTHER.                      30390000
SVOLDPSW DS    D                   APLSUP SVC OLD PSW.                  30400000
EXOLDPSW DS    D                   APLSUP EXT OLD PSW.                  30410000
DELPSW   DC    H'4'                USED TO SIMULATE MPX INT.       5991 30430000
         EXTRN MPXCH                                               5991 30440000
MPXCHANL DC    AL3(MPXCH-APLSVC)                                   5991 30450000
         ORG   *-1                                                 5991 30460000
         DC    A(EXTIME)      INTERRUPT AND GENERATE SGDELZ             30470000
         DC    H'255,0'          HALF OF DUMMY CSW                      30480000
         DC    F'0'                ZERO IS EIGHT BYTES                  30490000
*        STORED CCW ADDRESS IN DUMMY CSW IS SIGNAL TO STATUS BYTE       30500000
*        DECODER THAT THIS IS DELAY END.                                30510000
APLSAVE  DS    16F                 REGISTER SAVE AREA                   30530000
         SPACE                                                          30650000
*        IOB USED FOR ALL SELECTOR CHANNEL IO.                          30660000
         SPACE                                                          30670000
IOBD     DSECT                     , DEFINE IOB.                        30680000
IOBFLAG1 DS    X                   IO FLAGS 1.                          30690000
IOBFLAG2 DS    X                   IO FLAGS 2.                          30700000
IOBSENS0 DS    X                   FIRST SENSE BYTE.                    30710000
IOBSENS1 DS    X                   SECOND SENSE BYTE.                   30720000
IOBECBCC DS    X                   COMPLETION CODE.                     30730000
IOBECBPT DS    XL3                 ECB ADDRESS.                         30740000
IOBFLAG3 DS    X                   IO ERROR FLAGS.                      30750000
IOBCSW   DS    XL7                 SEVEN LOW ORDER BYTES OF LAST CSW.   30760000
IOBSIOCC DS    X                   SIO CONDITION CODE.                  30770000
IOBSTART DS    XL3                 ADDRESS OF CHANNEL PROGRAM.          30780000
IOBDCB   DS    X                   RESERVED.                       DASD 30790000
IOBDCBPT DS    XL3                 ADDRESS OF DCB.                      30800000
IOBRESTR DS    XL4                 PURGE CHAIN/CCHH/COMMAND, CHANNEL PR 30810000
IOBINCAM DS    XL2                 USE VARIES.                          30820000
IOBERRCT DS    XL2                 NO. OF ERROR RETRIES.                30830000
IOBSEEK  DS    XL8                 STAND ALONE SEEK ADDRESS.            30840000
*        FORM IS                   MBBCCHHR                             30850000
*        WHERE                     M IS DEB EXTENT NUMBER.              30860000
IOBDZ    EQU   *                   END OF IOB DEFINITION.               30870000
         SPACE                                                          30880000
*        IOBFLAG1 SETTINGS.                                             30890000
IOBF1DC  EQU   X'80'               DATA CHAINING.                       30900000
IOBF1CC  EQU   X'40'               COMMAND CHAINING.                    30910000
IOBF1ER  EQU   X'20'               ERROR ROUTINE IN CONTROL.            30920000
IOBF1RP  EQU   X'10'               DEVICE IS TO BE REPOSITIONED.        30930000
IOBF1CRC EQU   X'08'               CYCLIC REDUNDANCY CHECK IS NEEDED.   30940000
IOBF1PE  EQU   X'04'               EXCEPTIONAL CONDITION.               30950000
*        IF IOBF1PE IS SET ON RETURN FROM AN ERROR ROUTINE,             30960000
*              --  PERMANENT ERROR.                                     30970000
IOBF1UR  EQU   X'02'               IOB UNRELATED  (NON-SEQUENTIAL).     30980000
IOBF1RS  EQU   X'01'               RESTART (0 MEANS START).             30990000
         SPACE                                                          31000000
*        IOBFLAG2 SETTINGS.                                             31010000
IOBF2HIO EQU   X'80'               HALT I/O HAS BEEN ISSUED.            31020000
IOBF2SR  EQU   X'40'               SENSE REQUIRED WHEN DEVICE IS FREE.  31030000
IOBF2IP  EQU   X'20'               IOB HAS BEEN PURGED.                 31040000
IOBF2HA  EQU   X'10'               HOME ADDRESS IS TO BE READ.          31050000
IOBF2X08 EQU   X'08'               INTERNAL IOS FLAG.                   31060000
IOBF2X04 EQU   X'04'               INTERNAL IOS FLAG.                   31070000
IOBF2X02 EQU   X'02'               INTERNAL IOS FLAG.                   31080000
IOBF2X01 EQU   X'01'               QSAM - ERROR RECOVERY                31090000
*                                  WITH THREE BUFFERS.                  31100000
*                                  BTAM - RESETPL MACRO WAS USED.       31110000
         SPACE                                                          31120000
APLSUP   CSECT                                                          31130000
         ENTRY ATQE                                                     31140000
ATQE     DS    F                                                        31150000
TQEPSECT DS    8F                  MOTHER GIVES US A COPY OF HER TQE.   31160000
         DS    0F                  WORD ALLIGNMENT.                     31170000
DSKIOB   DC    (IOBDZ-IOBD)X'00'   DISK IOB.                            31180000
         ORG   DSKIOB+IOBECBPT-IOBD                                     31190000
         DC    AL3(DSKECB)         ECB ADDRESS.                         31200000
         ORG                                                            31210000
DSKECB   DC    0F'0',X'40',AL3(0)  DISK EVENT CONTROL BLOCK        C023 31220000
         SPACE                                                          31230000
*                                                                       31240000
*        MVT RELATED DEFINITIONS.                                       31250000
*                                                                       31260000
         SPACE                                                          31270000
         ENTRY TCBMERE                                                  31280000
*                                                                       31290000
*                                                                  2543 31300000
S15FOSXC DC    A(EMPT3)                 SAVE R15 IN SELEXCP        2543 31310000
S15FOS   DC    A(EMPT3)                 SAVE R15                   2543 31320000
MVTCSW   DS    CL8                 CSW SAVE AREA.                       31330000
**-------      THE ORDER OF THE NEXT  SIX  WORDS IS ASSUMED BY     C022 31340000
*        REAL MOTHER TASK.    DON'T CHANGE IT.                          31350000
TCBMERE  DS    F                   ADDRESS OF MOTHER TCB.               31360000
TCBFILLE DS    F                   ADDRESS OF DAUGHTER TCB.             31370000
RBMERE   DS    F                   ADDRESS OF MOTHER PRB.               31380000
RBFILLE  DS    F                   ADDRESS OF DAUGHTER PRB.             31390000
ECBMERE  DS    F                   ADDRESS OF MOTHER ECB.               31400000
ECBFILLE DC    F'0'                DAUGHTER ECB.                        31410000
**-------      SEE NOTE ABOVE                                      C022 31420000
         SPACE                                                          31430000
MXCVTTCB DS    2F                  SAVE AREA FOR CVTTCBP.               31440000
DCBNEXT  DS    F                   NEXT DCB FOR SELEXCP.                31450000
         ENTRY DAYSUP                                                   31460000
         ENTRY REALTIME                                                 31470000
DAYSUP   DC    F'0' NUMBER OF DAYS SINCE INITIATION IN SECONDS DIV 300. 31480000
K24HOURS DC    F'25920000'         24 HOURS IN SECONDS DIV 300.         31490000
APLFLAGS DC    AL1(IOBF1DC+IOBF1CC+IOBF1UR,0) APL SETTING OF IOBFLAG1,  31500000
*                                  AND IOBFLAG2.                        31510000
         SPACE                                                          31520000
*        EQUATES.                                                       31530000
         SPACE                                                          31540000
CVT      EQU   16                  LOCATION OF CVT POINTER.             31550000
CVTTCBP  EQU   0                   DISPLACEMENT OF CVTTCBP IN CVT.      31560000
CVTBTERM EQU   52                  ADDRESS OF ABTERM.              2217 31570000
CVTQTE00 EQU   104                 ENQ BRANCH ENTRY.                    31580000
CVTQTD00 EQU   108                 DEQ BRANCH ENTRY.                    31590000
CVTTPC   EQU   88             DISP. IN CVT OF ADDR OF OS PSEUDO CLOCKS  31600000
RBOPSW   EQU   16                  DISP OF RESUME PSW IN PRB.           31610000
TCBPIE   EQU   4              OFFSET OF  P.I.E.                    5997 31620000
TCBTME   EQU   120                 DISP OF TQE PTR IN TCB          2219 31630000
CVT0PT01 EQU   152                 DISP OF POST ADDR IN CVT.            31640000
UCBFL5   EQU   1                   DISP OF ALLOC CHAN MASK IN UCB. DASD 31650000
UCBCHA   EQU   4                   DISP OF CHANNEL/UNIT ADR IN UCB DASD 31660000
UCBSNS   EQU   22                  DISP OF SENSE BYTES IN UCB.          31670000
DCBL     EQU   72                  LENGTH OF APL DCB.                   31680000
DCBDEB   EQU   44                  THE ADDRESS OF THE DEB FROM DCB DASD 31690000
DEBUCB   EQU   32                  THE ADDRESS OF THE UCB FROM DEB DASD 31700000
         USING PERTERM,4          DROPZ BASE REGISTERS                  31760000
         USING PERCORE,5                                                31770000
*        INVALID SPECIAL DISK OP                                        31780000
DSZBAD   L     4,SDT               INDICATE TO INTERPRETER THAT         31790000
         OI    IOB1,TRREJ          DIRSEAR PRINTED ERROR MESSAGE        31800000
         B     DROPZ2                                              3598 31810000
*        END OF DIRECTORY WRITE DROP OR SAVE                            31820000
DROPZ    ST    LINK,SDQZSW         RESET SWITCH                    3598 31830000
DROPZ2   LM    4,5,SDT             &HDCORE                         3598 31840000
         L     3,PTCORE            DIRECTORY CORE SLOT                  31850000
         MVI   PCTERM+1-PERCORE(3),EMPTYM                               31860000
         ST    5,PTCORE            RECONNECT WORKSPACE                  31870000
         MVC   PCTERM+1(3),SDT+1   AND TERMINAL                         31880000
         DROP  4,5                                                      31890000
*        SDKILLA SHOULD ONLY BE EXECUTED WHEN SELCHANNEL IS IDLE        31900000
SDKILLA  MVI   CDCBASE+1,EMPTYM    FORCE PROG CK IF NOT SET BEFORE USE  31910000
*        TERMINATE A SPECIAL DISC OPERATION                             31920000
SDKILL   L     1,SDT              DESUSPEND TERMINAL OF SD OP           31930000
         NI    ACTIVE-PERTERM(1),255-LOCKM                              31940000
         MVI   SDT+1,EMPTYM                                             31950000
*        FOLLOWING LOOP DESUSPENDS TERMINALS WHICH ARE AWAITING         31960000
*        A SPECIAL DISC OPERATION AND SEARCHES FOR A TERMINAL WHICH     31970000
*        IS TRYING TO SIGN ON.                                          31980000
         LM    0,2,PTBXLE                                               31990000
         USING PERTERM,2                                                32000000
SDK1     TM    MISCB,WANTON+SDWAIT                                      32010000
         BZ    SDK2                IGNORE THIS TERMINAL                 32020000
         NI    MISCB,255-SDWAIT                                         32030000
         BNZ   SDK3                SIGN ON ENQUEUED                     32040000
         NI    ACTIVE,255-MISCM   ASSUME OLD MISCB=SDWAIT               32050000
SDK2     BXLE  2,0,SDK1                                                 32060000
         BR    LINK                                                     32070000
*        START SIGN ON PROCESS                                          32080000
SDK3     ST    2,SDT                                                    32090000
         MVC   SDQZSW(8),GETDIR   GET DIRECTORY INTO CORE               32100000
         MVI   SDOP,XXLEMP                                              32110000
         BR    LINK                                                     32120000
         DROP  2                                                        32130000
*                                                                       32150000
*        PLUS OVER SIGNED ON MAINTENANCE                                32160000
*        R0 IS EITHER +1 OR -1                                          32170000
*        LINK = RETURN                                                  32180000
POSOM    A     0,POSO                                                   32190000
         ST    0,POSO                                                   32200000
         BCR   8,LINK              AVOID DIVIDE BY ZERO                 32210000
         L     1,KOVERBOK          R1=TOTAL BUFFER COUNT TIMES OVER-    32220000
         SR    0,0                 BOOK FACTOR                          32230000
*        FAIR SHARE IS  20 MIN FLOOR R1 DIV PLUS / SIGNEDON             32240000
         D     0,POSO                                                   32250000
         CH    1,POSO2             COMPARE WITH MAX ALLOWED VALUE       32260000
         BL    *+8                                                      32270000
         LA    1,20                MAXIMUM OUTPUT BUFFER ALLOCATION     32280000
POSO2    EQU   *-2                 FOR CH ABOVE                         32290000
         ST    1,FSHARE                                                 32300000
         BR    LINK                                                     32310000
         EJECT                                                     C022 32320000
*        HISTOGRAM COMPUTATION                                          32330000
*                                                                       32340000
*        WHENEVER APL IS RUNNING, HISTOGRAM STATISTICS ARE COLLECTED    32360000
*        BY APLSUP.  THEY CAN BE ACCESSED FROM APL FUNCTIONS VIA THE    32370000
*        MONADIC IBEAM OPERATOR (EXMHIST).                              32380000
*        IF IT IS DESIRED TO SAVE CORE BY EXCLUDING THE HISTOGRAM       32390000
*        TABLES, REMOVE THE INCLUDE OF THE CSECT HTAB FROM THE LNKEDT.  32400000
*                                                                       32410000
*                                                                       32420000
* HIST   SCALE     I N F O R M A T I O N                           C041 32430000
*                                                                       32440000
*   0              SPECIAL DISK OPERATION FREQUENCY (SCALE IS SPD CODE) 32450000
*                                                                       32460000
*   1    PERCNT    FRACTION OF ELAPSED TIME USED FOR SERVICE            32470000
*                                                                       32480000
*   2    60/SEC    SYSTEM REACTION TIME (FROM EOB TO EXECUTION)    2547 32490000
*                                                                       32500000
*   3    1 SEC     USER KEYING TIME                                     32510000
*                                                                       32520000
*   4    60/SEC    COMPUTE TIME                                         32530000
*                                                                       32540000
*   5     ---      TRANSFER VECTOR OF ABSOLUTE ADDRESSES FOR OPFNS USE  32550000
*                                                                       32560000
*   6    1 MIN     CONNECT TIME FOR EACH SESSION                        32570000
*                                                                       32580000
*   7    .2 SEC    CPU TIME FOR EACH SESSION                       2547 32590000
*                                                                       32600000
*   8    1 BYTE    RAW INPUT CHARACTER COUNT                            32610000
*                                                                       32620000
*   9    1 SEC     INPUT ARRIVAL TIME (FROM EOB TO EOB)                 32630000
*                                                                       32640000
*  10    1 BYTE    INTERNAL OUTPUT LINE LENGTH                          32650000
*                                                                       32660000
*  11    2 BUFF    FREE BUFF COUNT AT STYONO                            32670000
*                                                                       32680000
*  12    1 BUFF    PTBFA AT STYONO                                      32690000
*                                                                       32700000
*  13    250 BYTES GARBAGE IN WS AT SWAP WRITE                          32710000
*                                                                       32720000
*  14    250 BYTES ACTIVE SIZE OF WS AT SWAP WRITE                      32730000
*                                                                  2219 32740000
*  15    APL TU    CPU TIME PER QUANTUM (IN 1/300 SECONDS)         2219 32750000
*                                                                  3064 32770000
*  16    APL TU     CPU TIME AT HIGH PRIORITY                      3064 32780000
*                                                                  3064 32790000
*  17    APL TU     CPU TIME AT LOW  PRIORITY                      3064 32800000
*                                                                       32820000
PERHIST  DSECT                                                          32830000
PHINF    DS    F                 VALUE OF INFINITY, THIS HISTOGRAM      32840000
PHSCALE  DS    F                 DIVISOR OF READING                     32850000
PHORG    DS    F                 START OF VALUE STORAGE AREA            32860000
APLSUP   CSECT                                                          32870000
         USING PERHIST,PHR                                              32880000
*        PARAMETERS TO HISTCOMP ARE IN REGISTERS: HISTVAL & PHR         32890000
*        HISTCOMP IS RE-ENTRENT EXCEPT FOR CALLS OF SAME TABLE.         32900000
         ENTRY HISTKILL            SO THAT SUPINI CAN MODIFY IT $$$$$$$ 32910000
HISTCOMP NOPR  0                   SUPINI MAY MODIFY TO BR LINK $$$$$$  32920000
HISTKILL EQU   HISTCOMP                                                 32930000
         LTR   HISTVAL,HISTVAL                                          32940000
         BNL   *+6                                                      32950000
         SR    HISTVAL,HISTVAL     NEGATIVE VALUE NOT ALLOWED           32960000
         SR    HISTVAL-1,HISTVAL-1                                      32970000
         D     HISTVAL-1,PHSCALE   SCALE READING                        32980000
         LR    HISTVAL-1,HISTVAL                                        32990000
         S     HISTVAL-1,PHINF     MAKE SURE READING IS IN RANGE        33000000
         BM    HISTOK                                                   33010000
*                                  IF READING IS NOT IN RANGE,          33020000
         L     HISTVAL,PHORG       PRESERVE ITS VALUE IN A FULL WORD    33030000
         A     HISTVAL-1,0(HISTVAL)  COUNTER (FOR CALCULATING MEAN),    33040000
         ST    HISTVAL-1,0(HISTVAL)  AND ASSUME INFINITY.               33050000
         L     HISTVAL,PHINF                                            33060000
HISTOK   AR    HISTVAL,HISTVAL     MAKE SCALED READING A HALFWORD INDEX 33070000
         A     HISTVAL,PHORG       ADD TABLE ORG, GIVING COUNTER ADDR   33080000
         LH    PHR,4(HISTVAL)                                           33090000
         LA    PHR,1(PHR)          INCREMENT COUNTER                    33100000
         STH   PHR,4(HISTVAL)                                           33110000
         BR    LINK                                                     33120000
         DROP  PHR                                                      33130000
*                                                                       33140000
         USING PERTERM,PTR                                              33150000
LEMP     SSM   ALLOFF              REQUEST TO LOAD EMPTY WORKSPACE      33160000
         MVI   ACTIVE,MISCM        FORCE SUSPENSION                     33170000
         PTSET ACTIVE                                                   33180000
         MVI   MISCB,WANTON+NOWSM                                       33190000
         PTSET MISCB                                                    33200000
         CLI   SDT+1,EMPTYM                                             33210000
         BCR   7,LINK BNER         SPECIAL DISK OPERATION GOING ON NOW  33220000
         ST    PTR,SDT            SIGN ON IS SPECIAL DISK OP            33230000
         MVC   SDQZSW(8),GETDIR                                         33240000
         MVI   SDOP,XXLEMP                                              33250000
         BR    LINK                                                     33260000
         USING PERTERM,PTR                                              33270000
*        SUBROUTINE TO SET STORAGE KEYS IN ONE WORKSPACE                33280000
*        R3 = NEW KEY                                                   33290000
*        R6 = WS ORIGIN                                                 33300000
*        LINK = RETURN                                                  33310000
SSKSUB   LA    4,2048              PROTECT BLOCK SIZE                   33320000
         N     6,SSKALGN           2K BOUNDARY AND ZERO TOP BYTE.       33330000
         LR    5,6                                                      33340000
         A     5,WLEN              END OF WS ADDR                       33350000
         BCTR  5,0                 IN CASE 0=SSKINC RESIDUE WLEN        33360000
SSKS1    SSK   3,6                                                      33370000
         BXLE  6,4,SSKS1                                                33380000
         BR    LINK                                                     33390000
*                                                                       33400000
TYOSUB   L     8,=A(REMTYO)        MOST OF TYO IS ABOVE MPXSAVE BASE RE 33410000
         BR    8                                                        33420000
*        TYOSUB IS CALLED FROM SCHEDULER                                33430000
*        DEVXCC IS CALLED BY TYOSUB, THEREFORE DEVXCC MUST BE IN LOW CO 33440000
*        COMPUTE BASE REGISTER TO ADDRESS PERDEVX                       33450000
DEVXCC   SR    6,6                                                      33460000
         IC    6,PTTYPE                                                 33470000
         A     6,PERDEVB                                                33480000
         BR    1                                                        33490000
*        RETURN ADDRESS IS R1, RESULT IS IN R6                          33500000
*                                                                       33510000
*        SET CPU TIME LIMIT TO ONE SECOND FOR DOUBLE ATTENTION AND BOUN 33520000
*        R5 = RETURN                                                    33530000
SHCPUSUB EQU   *                                                        33540000
         TM    IOB1,COPYRM         DON'T TERMINATE COPY SINK            33560000
         BCR   7,5 BNZR                                                 33570000
         LM    0,1,PTABTM+(PTICTME-PTICTME)                             33590000
         AR    0,1                 ADD PTICTME TO PTABTM BEFORE ZEROING 33600000
         SR    1,1                 ACCOUNTING WILL BE OKAY BUT COMPUTE  33610000
*                                  TIME PER TYI HISTOGRAM WILLL NOT     33620000
*                                  INCLUDE PREVIOUS PTICTME VALUE       33630000
         STM   0,1,PTABTM          SET PTICTME TO ZERO FOR QZM2 COMPARE 33640000
         LA    0,10                ONE SECOND TIME LIMIT                33650000
         STH   0,PTCPULIM          ALLOW ONE SECOND                     33660000
         BR    5                                                        33670000
*                                                                       33680000
         DROP  PTR                                                      33690000
         DC    0D'0'              ALIGN LTAR LIKE LTORG DOES       C022 33700000
LTAR     DC    40F'0'              SPACE FOR LITERALS              C022 33720000
LTARZ    EQU   *                   FOR OVERRUN CHECK                    33770000
PATCH    DC    12D'0'              SPACE FOR PATCHES               C022 33780000
         ENTRY PATCH                                                K10 33790000
         TITLE 'A P L S U P   S C H E D U L E R               05/11/70' 33800000
*    SCHEDULER FUNCTIONS...                                             33810000
*        ENTERED AT QUEND (OR QZA0 VIA QZA7)                            33820000
*                                                                       33830000
*   A) QUANTUM TERMINATION                                              33840000
*        CODE FROM QUEND TO QZA0 IS CONCERNED WITH END OF TIME SLICE    33850000
*        FOR A PARTICULAR TERMINAL.  FLOATING REGISTER SAVE, TIME       33860000
*        ACCOUNTING, STATISTICS, ETC. ARE PERFORMED HERE.               33870000
*                                                                       33880000
*   B) PERIODIC SCAN OPERATIONS                                         33890000
*        CODE FROM QZA0 TO QZA2 IS A SCAN TO INITIATE VARIOUS TASKS.    33900000
*        THIS CODE PERFORMS TASKS REQUESTED BY VARIOUS INTERRUPT        33910000
*        ROUTINES.  THE SCANNING CODE IS MOSTLY EXECUTED WITH INTERRUPT 33920000
*        ENABLED AND HAS THE ADVANTAGE OF BEING EXECUTED FAIRLY FRE-    33930000
*        QUENTLY (SEVERAL TIMES PER SECOND).  SCANNING FUNCTIONS        33940000
*        INCLUDE DISK ERROR LOGGING, RECEPTION OF MESSAGES TO THE       33960000
*        OPERATOR, SPECIAL DISK MOPUP AND SWAP INITIATION.              33970000
*                                                                       34050000
*   C) TASK DISPATCHING                                                 34060000
*        CODE FROM QZA2 TO QZB2 ATTEMPTS TO FIND AN ACTIVE APL TERMINAL 34070000
*        IN CORE.  THE CODE AT QZA3 PASSES CONTROL TO THE INTERPRETER.  34080000
*                                                                       34090000
*   D) WAIT STATE                                                       34100000
*        QZA7 IS REACHED WHEN SCHEDULER CAN FIND NO USEFUL WORK.        34110000
*        ANOTHER PARTITION OR THE WAIT STATE IS ENTERED UNTIL SOMETHING 34120000
*        HAPPENS AT WHICH TIME THE PERIODIC SCAN AT QZA0 IS STARTED.    34130000
*                                                                       34140000
*   E) SWAPPING WRITE SCHEDULER                                         34150000
*        CODE FROM QZB2 TO EXECDSER DECIDES IF SWAP OPERATION IS        34170000
*        DESIRABLE NOW.  IF SO, A WRITE OR POSSIBLY A READ IS INITIATED 34180000
*                                                                       34190000
*   F) DIRECTORY SEARCH INITIATION                                      34200000
*        CODE AT EXECDSER IS PART OF SPECIAL DISK AND IS ENTERED WHEN   34210000
*        A DIRECTORY HAS BEEN BROUGHT INTO CORE.  NORMALLY THE TASK     34220000
*        REQUIRING AN EXECUTION OF THE DIRECTORY SEARCH ROUTINE IS      34230000
*        FORCED INTO EXECUTION.                                         34240000
*                                                                       34260000
*        START OF SCHEDULER                                             34270000
         DS    0F                  ALIGN QUEND & SCHSAVE                34280000
QUEND    BAL   MR,QUEND1           SETTING MR TO SCHSAVE                34290000
         USING SCHSAVE,MR                                               34300000
SCHSAVE  DS    16F                 REGISTER STORAGE (SCHEDULER)         34310000
*        END   OF QUANTUM                                               34320000
         USING PERTERM,PTR       SVINT LOADED FOR US                    34330000
         USING M,PXR             SVINT LOADED                           34340000
QUEND1   STD   0,FRSAVE                                                 34350000
         STD   2,FRSAVE+8                                               34360000
         STD   4,FRSAVE+16                                              34370000
         STD   6,FRSAVE+24                                              34380000
PSWSAVE  MVC   FRSAVE+32(8),SVOLDPSW                                    34390000
         BAL   LINK,CORTIME        READ CLOCK                           34400000
         RESET UGHSW,SVC                                           2217 34410000
         LA    MR,SCHSAVE          TO ALLOW ALL INTERRUPTS              34420000
         ST    MR,CURRENTM       FOR MPXEXIT                            34430000
         L     1,QZPRG                                                  34440000
         BAL   LINK,PRGIE     PURGE SETBELL OR SETPAN                   34450000
         QZACT                                                          34460000
         LR    6,PXR                                                    34470000
         IC    3,INACTKEY          RESET STORAGE KEY FOR THIS WS        34480000
         BAL   LINK,SSKSUB         TO INACTIVE KEY                      34490000
*        R0 IS DURATION OF LAST QUANTUM IN TRECENTISECONDS              34500000
*                                                                  2219 34510000
*   GATHER CPU-TIME PER QUANTUM                                    2219 34520000
*                                                                  2219 34530000
         LR    2,0            SAVE FOR LATER USE                   2219 34540000
         LR    HISTVAL,0                                           2219 34550000
         LA    PHR,PERHQCPU                                        2219 34560000
         BAL   LINK,HISTCOMP  STUFF AWAY CPU/QUANTUM               2219 34570000
*                                                                  2219 34580000
         LR    0,2            PUT IT BACK FOR CODE BELOW           2219 34590000
         SSM   ALLON                                                    34600000
         A     0,PTICTME                                                34610000
         LR    2,0                                                      34620000
         LR    HISTVAL,0                                                34630000
         TM    SWITCHES,QZSW1 HAS SVTYI SET SWITCH TO ZERO?        C022 34640000
         BO    QZM1           B. IF NOT                            C022 34650000
*        QUANTUM TERMINATED BY TYI.  R0 NOW CONTAINS COMPUTE TIME       34660000
*        REQUIRED TO SERVICE THE PREVIOUS TYI                           34670000
         A     0,PTABTM            TOTAL COMPUTE TIME SINCE SIGNON      34680000
         ST    0,PTABTM                                                 34690000
         SR    0,0                                                      34700000
         LA    PHR,PERHGRND                                             34720000
         BAL   LINK,HISTCOMP                                            34730000
         LR    0,2                                                      34740000
         L     2,REALTIME                                               34750000
         S     2,PTMTIM2           SET AT STYIZ                         34760000
*        R2 GIVES ELAPSED TIME FROM FINISH OF PREVIOUS TYI (STYIZ) TO   34770000
*        INTERPRETER EXECUTING ANOTHER TYI.  THE 1050 MAY STILL BE RE-  34780000
*        CEIVING OUTPUT.                                                34790000
         LA    PHR,PERHELFR                                             34800000
         CLR   0,2                                                      34810000
         BNL   QZM0                AVOID DIVIDE BY ZERO                 34820000
         SR    HISTVAL,HISTVAL                                          34830000
         SRDA  HISTVAL-1,8        COMPUTE TRUE QUOTIENT TIMES 2*23      34840000
         DR    HISTVAL-1,2                                              34850000
         B     *+8                                                      34860000
QZM0     L     HISTVAL,0(PHR)      SCALED 1.0                           34870000
         BAL   LINK,HISTCOMP                                            34880000
*        QUOTIENT IS FRACTION OF AVAILABLE MACHINE TIME USED TO         34900000
*        SERVICE PREVIOUS TYI.  IF THIS EXCEEDS (1 DIV +/SIGNEDON)      34910000
*        HE GOT MORE THAN HIS SHARE                                     34920000
         OI    SWITCHES,QZSW1 RESET SWITCH                         C022 34930000
         SR    1,1                 ZERO COMPUTE TIME                    34940000
QZM1     ST    1,PTICTME                                                34950000
*        FORCE ATTENTION AND CPU TIME LIMIT CODE.                       34960000
QZM2     TM    PTCPULIM,EMPTYM     CHECK FOR A TIME LIMIT.              34970000
         BO    QZM3                BRANCH IF NO TIME LIMIT.             34980000
         SR    0,0                 TURN TIMER-UNIT CPU TIME INTO        34990000
         D     0,LMB30             0.1 SEC UNITS.                       35000000
         SH    1,PTCPULIM          SUBTRACT TYI-TO-TYI CPU LIMIT        35010000
*              NOTES ... WE CAN'T BE MORE THAN A FEW TENTHS OF A SECOND 35030000
*                  OVER THE CPU LIMIT OR WE WOULD HAVE CAUGHT IT AT     35040000
*                  THE LAST QUEND.  HENCE R1 IS SMALL IF POSITIVE.      35050000
*                  THE FOLLOWING COMPARISON FORCES ATTENTION IFF        35060000
*                  (PTICTME GEQ PTCPULIM) AND ONATTN NEQ 0              35070000
*                  TO AVOID FORCING ATTENTION IF ATTN ON-CONDITION      35080000
*                  IS DISABLED.                                         35090000
         CL    1,ONATTN            R1 GUARANTEED LARGER IF NEGATIVE     35100000
         BNL   QZM3                R1 ALSO LARGER IF ONATTN DOESN'T     35110000
*                                  CONTAIN AN INTERP ENTRY ADDRESS.     35120000
         NI    ACTIVE,255-ATTENM   REMOVE ATTENTION FLAG.               35180000
QZMRST   MVC   PTCPULIM(2),PTCPULM2  RESTORE CPU LIMIT IN CASE OF       35190000
*                                  DOUBLE ATTN WHICH SETS 2-SEC LIMIT   35200000
*                                  IN PTCPULIM.                         35210000
QZM4     MVC   FRSAVE+37(3),=AL3(BGATTN) FORCE ENTRY TO BGATTN AT START 35220000
*                                  OF NEXT QUANTUM.                     35230000
         EXTRN BGATTN                                                   35240000
*        PRECEDING CODE IS OVERHEAD CONCERNED WITH ENDING QUANTA        35250000
         DROP  PXR,PTR                                                  35260000
*        FOLLOWING CODE IS SCHEDULING ALGORITHM                         35270000
QZM3     EQU   *                   LAST QUANTUM END CODE                35280000
QZA0     EQU   *                   START PERIODIC SCAN                  35290000
         L     5,OPTERM                                                 37330000
         DC    0AL4(DUMINACT)      WHEN NO OPR, OPTERM=A(DUMINACT)      37340000
         TM    IOB1-PERTERM(5),BROADM+RINGM                             37350000
         BZ    QZE1           NO MESSAGE FOR OPERATOR                   37360000
         ST    5,PTBASE                                                 37370000
         TM    ACTIVE-PERTERM(5),INWAITM                                37380000
         BNZ   QZE1                                                     37390000
         SVCC  YYREC               RECEIVE MESSAGES FOR OPERATOR.       37400000
         QZE1                                                           37410000
         SPACE 2                                                   DASD 37430000
*    IF THE ABNORMAL END APPENDAGE RETURNED TO IOS FOR RECOVERY    DASD 37440000
*    AND IOS ERROR RECOVERY FAILED, THE ECB WILL BE POSTED BY IOS  DASD 37450000
*    BUT SELBUSY WILL STILL BE 1  BECAUSE IOS DOES NOT RE-ENTER    DASD 37460000
*    THE ABNORMAL END APPENDAGE AFTER ERROR RECOVERY FAILURE.      DASD 37470000
*    THIS WILL NOT HAPPEN FREQUENTLY, BUT WHEN IT DOES, WE WISH    DASD 37480000
*    TO NOTIFY THE APL OPERATOR AND TAKE APPROPRIATE ACTION.       DASD 37490000
*                                                                  DASD 37500000
QZE3     TM    DSKECB,X'40'   IF EXCP IS NOT COMPLETED,            DASD 37510000
         BZ    QZA2           SEEK AN ACTIVE USER IN CORE          DASD 37520000
*    IOS HAS POSTED US WITH AN ERROR COMPLETION CODE               DASD 37530000
*        CALL ERROR RECOVERY                                       DASD 37540000
*                                                                  DASD 37550000
*        WE COUNT ON HAVING GONE THROUGH SELRTRY AT LEAST ONCE     DASD 37560000
         L     10,=A(SELSTAR)                                      DASD 37570000
         XC    DCBNEXT,DCBNEXT TELL SELEXCP WE'RE IN THE SCHEDULER DASD 37580000
         LA    LINK,QZE1                                           DASD 37590000
         B     SELRTR2-SELSTAR(10) PERFORM ERROR RECOVERY RECOVERY DASD 37600000
*                                                                  DASD 37610000
QZE2     L     10,SDQZSW           SPECIAL DISK OP SWITCH               37630000
         BALR  LINK,10             USUALLY TO QZD0                      37640000
*        POSSIBLE SETTINGS OF SDQZSW ARE                                37650000
*              QZD0, MAKHOL, EXECDSER, CONTDSER, DROPZ             C011 37660000
*                                                                       37670000
*        COMPUTE                 OR / ACTIVE AND NOT INCORE             37680000
         USING PERDISK,3                                                37690000
QZD0     LM    0,3,PDBXLE                                               37700000
         USING PERTERM,4                                                37860000
QZD3     CLI   PDTERM+1,EMPTYM                                          37870000
         BZ    QZD2                EMPTY DISK AREA.                     37880000
         L     4,PDTERM                                                 37890000
         TM    ACTIVE,ACTIVEM                                           37900000
         BC    8,QZD1              AN ACTIVE USER IS ON DISK            37910000
QZD2     BXLE  3,0,QZD3                                                 37920000
         DROP  3,4                                                      37930000
*        NO ACTIVE USER ON DISK, LEAVE SELECTOR CHANNEL IDLE            37940000
*                                                                       37950000
*        SEARCH FOR AN ACTIVE USER IN CORE                              37960000
*        SEARCH STARTS WITH SLOT AFTER THE CURRENT SLOT                 37970000
QZA2     LM    0,4,PCBXLE                                               37980000
         USING PERCORE,4                                                38020000
         USING PERTERM,5                                                38030000
QZA6     BXLE  4,0,QZA5                                                 38040000
         LR    4,2                                                      38050000
QZA5     TM    PCTERM+1,EMPTYM                                          38060000
         BC    7,QZA4              SLOT IS EMPTY                        38070000
         L     5,PCTERM                                                 38080000
         TM    ACTIVE,ACTIVEM+LOCKM                                     38090000
         BC    8,QZA3            RUN THIS GUY                           38100000
QZA4     BCT   3,QZA6              EXAMINE ALL SLOTS                    38110000
*        NO ACTIVE USER IN CORE                                         38120000
*        WE ARE WASTING CPU TIME.                                       38130000
*        IF AN ACTIVE USER IS ON DISK, A PREVIOUS CHOICE AS TO WHICH    38140000
*        WORKSPACE TO WRITE OUT MAY HAVE BEEN WRONG.  NO ACTIVE USER    38150000
*        ON DISK EXONERATES US.                                         38160000
         LM    2,4,PCBXLE          INCREMENT PCQUONT (/ALL/) BY 1       38170000
         USING PERCORE,4           .                                    38180000
QZA8     LH    1,PCQUONT           TO PREVENT TROUBLE WITH LOCKM        38190000
         LA    1,1(0,1)            AND PCQUONT = 0 DURING COPY WHEN     38200000
         STC   1,PCQUONT+1         INCORE = 2.                          38210000
         BXLE  4,2,QZA8                                                 38220000
         DROP  4                                                        38230000
*                                                                       38240000
         QZA7                      ,NO APL USER WANTS SERVICE           38250000
*                                                                       38260000
CONTDSER L     4,RRCORE            QUANTUM ENDS IN DIRECTORY SEARCH ARE 38270000
         USING PERCORE,4                                                38280000
         L     5,SDT               IGNORED AND SWAPPING IS INHIBITED    38290000
*        FIRE UP THE INTERPRETER                                        38300000
QZA3     LH    1,PCQUONT         INCREASE COUNT                         38310000
         LA    1,1(1)                                                   38320000
         STC   1,PCQUONT+1         COUNT RESIDUE 256                    38330000
         ST    4,RRCORE   FOR NEXT TIME AT QZA2                         38340000
         ST    5,PTBASE            CURRENT PERTERM AREA                 38350000
         MVI   PTBASE,0             REMOVE HIGH ORDER GARBAGE           38370000
         SSM   ALLOFF              * * * * * * *                        38380000
         MVC   CURRENTM+1(3),PCADDR                                     38390000
         DROP  4                                                        38400000
         LM    2,3,QUANLIM    QUANTUM LIMIT EVENT                       38410000
         ST    2,QZPRG             FOR PURGE AT QUEND                   38420000
         BAL   5,ENQIE             QUEND MAY PURGE                      38430000
         L     5,PTBASE       RESTORE BASE REGISTER                     38450000
         L     2,CURRENTM                                               38470000
         USING M,2                                                      38480000
         MVC   MQCELL,NOPR                                              38540000
         LD    0,FRSAVE                                                 38550000
         LD    2,FRSAVE+8                                               38560000
         LD    4,FRSAVE+16                                              38570000
         LD    6,FRSAVE+24                                              38580000
*        R0 STILL CONTAINS REALTIME                                     38590000
         TM    ACTIVE,NONINM       COMPUTE HISTOGRAM                    38600000
         BZ    STYIZ0              IF AWAITING INPUT                    38610000
STYIZ1   ST    0,PTMTIME                                                38620000
         QAACT             ,QUANTUM ACTIVATION ACCOUTING                38630000
         LR    6,2                 R6 IS PCADDR, THIS WS                38640000
         IC    3,ACTKEY            ACTIVE KEY                           38650000
         BAL   LINK,SSKSUB         SET STORAGE KEY                      38660000
         LM    0,15,REGSV                                               38670000
         LPSW  FRSAVE+32-M(MR)     ENTER INTERPRETER                    38680000
*                                                                       38690000
*                                                                       38700000
*        FIRST QUANTUM AFTER TYPIST SEND EOB OF TYI                     38710000
STYIZ0   TM    IOB1,COPYRM+COPYWM  COPY TERMINALS REMAIN HIGH           38720000
         BNZ   STYIZ1              PRIORITY AND GET NO HISTOGRAMS       38730000
         OI    ACTIVE,NONINM       SET TO LOW PRIORITY                  38740000
         LR    HISTVAL,0                                                38800000
         S     HISTVAL,PTMTIME     GIVING RESPONSE TIME                 38810000
         ST    0,PTMTIME           TO MEASURE COMPUTE TIME              38820000
*        FINISH TYI                                                     38830000
*        INFORMATION DELIVERED TO INTERPRETER AT TYI                    38840000
*        PTIBUF POINTS TO CHAIN OF TRANSLATED BUFFERS                   38850000
         LA    PHR,PERHRES         RESPONSE TIME HISTOGRAM              38860000
         BAL   LINK,HISTCOMP                                            38870000
*        HISTOGRAM ON REACTION TIME   **************************        38880000
         L     0,REALTIME                                               38890000
         B     STYIZ2                                                   38900000
         DROP  2,5                                                      38910000
*                                                                       38920000
         USING PERTERM,3                                                38930000
         USING PERCORE,2                                                38940000
QZB2     LR    5,2                 CORE SLOT OF INACTIVE TERMINAL       38950000
*        AN INACTIVE SLOT HAS BEEN FOUND, SEARCH FOR EMPTY SLOT         38960000
         BXH   2,0,QZB5          NO MORE SLOTS                          38970000
         TM    PCTERM+1,EMPTYM                                          38980000
         BC    8,QZB2+2                                                 38990000
*        FOUND AN EMPTY SLOT                                            39000000
*        EMPTY SLOT EXISTS, SKIP WRITE                                  39010000
QZB4     ST    2,CDCORE            FAKE A PRIOR WRITE                   39020000
         SSM   ALLOFF                                                   39030000
         MVC   CDCAD+1(3),PCADDR-PERCORE(2)                             39040000
         BAL   LINK,RSELSUB        SELECT DISK AREA AND START READ      39050000
         SSM   ALLON               RESTORE SYSTEM MASK                  39060000
         B     QZA2                SELECTOR CHANNEL IS NOW BUSY         39070000
*                                                                       39080000
*        FOLLOWING CODE CHECKS FOR AN EMPTY SLOT IN CORE.  IF THERE IS  39090000
*        NO SLOT, IT SEARCHES FOR A WORKSPACE TO WRITE OUT TO DISK.     39100000
MAKHOL   ST    LINK,SDQZSW         TURN OFF SDQZSW                      39110000
         MVI   FSWAP,1             FORCE SWAP                           39120000
         B     *+8                                                      39130000
QZD1     STM   0,3,SCHTEM          LOCATES FIRST ACTIVE USERS ON DISK   39140000
         LM    0,2,PCBXLE                                               39150000
         LA    5,1                 CAUSE PROGCHECK AT QZB5 R5 NOT CHANG 39160000
         LCR   4,0       MAXIMUM QUONT VALUE                            39170000
QZB1     TM    PCTERM+1,EMPTYM                                          39180000
         BC    7,QZB4            FOUND AN EMPTY SLOT                    39190000
         L     3,PCTERM                                                 39200000
         TM    ACTIVE,ACTIVEM                                           39210000
         BC    7,QZB2            SLOT IS INACTIVE                       39220000
*        TEST FOR MAXIMUM RESIDENCE IN CORE                             39230000
         CH    4,PCQUONT                                                39240000
         BH    QZB3                                                     39250000
         LH    4,PCQUONT         NEW MAXIMUM                            39260000
         LR    5,2               CORE SLOT OF NEW MAX                   39270000
QZB3     BXLE  2,0,QZB1                                                 39280000
         DROP  2,3                                                      39290000
*        NO EMPTY OR SUSPENDED USER IN CORE                             39300000
*        TRADITIONALLY APL SWAPPING WAS INITIATED WHENEVER THERE WAS AN 39310000
*        ACTIVE USER ON DISK.  THE FOLLOWING LOGIC SERVES TO INHIBIT    39320000
*        SWAPPING UNDER HEAVY COMPUTE LOAD CONDITIONS.  SWAPPING IS     39330000
*        ALWAYS INITIATED IF A USER WITH INPUT READY IS ON THE DISK.    39340000
*        SWAPPING MAY BE INITIATED LESS FREQUENTLY (EVERY TENTH         39350000
*        PASSAGE THROUGH SCHEDULER WITH DISK IDLE) IF ALL USERS IN CORE 39360000
*        ARE ACTIVE AND NO USER  IN CORE IS SUSPENDED.                  39370000
         CLI   FSWAP,1             UNRZ,MAKHOL FORCED SWAP FLAG         39380000
         MVI   FSWAP,0                                                  39390000
         BE    QZB5                DISK CONTAINS EITHER A USER WITH     39400000
*              INPUT READY OR AN ACTIVE USER WHO SHOULD HAVE BEEN       39410000
*              BROUGHT IN WITH PREVIOUS SWAP.                           39420000
         TR    HCSCNT(1),HCSTR     COUNT MODULO TEN                     39430000
         CLI   HCSCNT,0                                                 39440000
         BE    QZB5                FORCE ACTIVE USER OUT AND BRING IN   39450000
*                                  ANOTHER HEAVY COMPUTE.               39460000
*        COMPUTE (AND/NONINM) AND INITIATE SWAP ONLY IF THIS IS ZERO.   39470000
         LM    0,3,SCHTEM          SKIP INACTIVE USERS                  39480000
         USING PERDISK,3           AT LOW ORDER END OF DISK             39490000
         USING PERTERM,2                                                39500000
QZF1     CLI   PDTERM+1,EMPTYM                                          39510000
         BE    QZF2                                                     39520000
         L     2,PDTERM                                                 39530000
         TM    ACTIVE,NONINM                                            39540000
         BZ    QZB5                INPUT READY                          39550000
QZF2     BXLE  3,0,QZF1                                                 39560000
         DROP  2,3                                                      39570000
*        AVOID SWAP EVEN THOUGH DISK CONTAINS AN ACTIVE USER.           39580000
         B     QZA2                                                     39590000
*                                                                       39600000
         USING PERCORE,5         SLOT TO WRITE TO DISC                  39610000
*        INTIATE NORMAL DISK WRITE                                      39620000
QZB5     L     4,PCTERM                                                 39630000
         SSM   ALLOFF              UNRZ COULD CAUSE TROUBLE HERE        39640000
         STM   4,5,CDTERM                                               39650000
         MVI   PTCORE+1-PERTERM(4),EMPTYM                               39660000
         L     4,ARM                                                    39670000
         CLI   PDTERM+1-PERDISK(4),EMPTYM CHECK FOR ALLOCATION ERROR    39680000
         BE    QZB6                CYLINDER IS EMPTY, GOOD              39690000
         BAL   6,MAKCYL            CREATE AN EMPTY CYLINDER             39700000
         LR    4,2                 NEW VALUE OF ARM                     39710000
QZB6     ST    4,CDDISK                                                 39720000
         MVC   PDTERM+1-PERDISK(3,4),PCTERM+1                           39730000
         BAL   LINK,CDCOMPW        COMPUTE CHAIN  AND  SIO              39740000
         SSM   ALLON               REENABLE INTERRUPTS                  39750000
         L     4,CDCAD             ADDRESS OF MR                        39770000
         L     HISTVAL,MINGL-M(4)  HISTOGRAM OF TOTAL AMOUNT OF MARKED  39780000
         LA    PHR,PERHGARB        GARBAGE IS WS AT SWAP WRITE          39790000
         BAL   LINK,HISTCOMP                                            39800000
         LM    3,4,MX-M(4) SVI     HISTOGRAM OF SIZE OF ACTIVE WS       39810000
         SR    4,3                 (INCLUDING MARKED GARBAGE) AT SWAP   39820000
         L     HISTVAL,WLEN        WRITE                                39830000
         SR    HISTVAL,4                                                39840000
         LA    PHR,PERHWSIZ                                             39850000
         BAL   LINK,HISTCOMP                                            39860000
         B     QZA2                                                     39880000
         DROP  5                                                        39890000
*        PREPARE TO SEARCH OR PRINT DIRECTORY OF SAVED WORKSPACES       39900000
*        EXECDSER IS ENTERED VIA SDQZSW                                 39910000
EXECDSER MVC   SDQZSW,=A(CONTDSER)   IGNORE QEND FROM DIRSEAR           39920000
         L     4,CDCORE           DIRECTORY SLOT                        39930000
         L     5,SDT                                                    39940000
         USING PERTERM,5                                                39950000
         USING PERCORE,4                                                39960000
         MVC   HDCORE+1(3),PTCORE+1 REMEMBER TRUE WORKSPACE LOCATION    39970000
         ST    4,PTCORE                                                 39980000
         MVC   PCTERM+1(3),SDT+1                                        39990000
         MVI   ACTIVE,NONINM      NOT TYIZ                              40000000
         PTSET ACTIVE                                                   40010000
         L     1,CDCAD             MR OF DIRECTORY                      40020000
         USING M,1                                                      40030000
         NI    FRSAVE+33,254       FORCE SUPVR STATE SO PROGCHECK=HALT  40040000
         MVC   FRSAVE+36(4),=V(DIRSEAR)  SETUP ENTRY POINT IN PSW       40050000
         MVC   REGSV+7*4(8),HDCORE & CDCBASE                            40060000
         CLI   SDOP,XXLIB                                               40070000
*        LIBRARY OP AT QZ WITH DIRECTORY IN CORE                        40080000
         BNE   QZA3                SEARCH DIRECTORY                     40090000
         EX    0,SDSWRSET          DIRECTORY SEARCH IS FINISHED         40100000
         SSM   ALLOFF              * * * * * * * * * * * * *            40110000
         L     4,ARM                                                    40120000
         ST    4,CONCEAL           USED AT SVLIBZ                       40130000
         STM   4,5,CDDISK                                               40140000
         MVC   PDTERM+1-PERDISK(3,4),=AL3(DUMINACT)                     40150000
         L     5,HDCORE           TRUE WORKSPACE IS FORCED TO DISK      40160000
         ST    5,CDCORE                                                 40170000
         MVI   CDCBASE+1,EMPTYM    FORCE PROG CK IF NOT SET BEFORE USE  40180000
         BAL   LINK,CDCOMPW        COMPUTE CHAIN  AND  SIO              40190000
         SSM   ALLON                                                    40200000
         BAL   LINK,SDKILL        THUS ENDING SPECIAL DISK OP           40210000
         B     QZA0                                                     40220000
         DROP  1,4,5               EXECDSER END                         40230000
*                                                                       40270000
*                                                                       40280000
         USING PERDEVX,PXR                                              40290000
         USING PERTERM,PTR                                              40300000
         USING MPXSAVE,MR                                               40310000
*        END OF SCHEDULER BASE REGISTER  ------------------             40320000
*                                                                       40330000
*        FRACTION OF ELAPSED TIME USED FOR SERVICE                      40370000
         PRINT GEN                                                      40380000
ELFR     PHGEN X'800000',101,1    SCALED 1.0 MAX                        40390000
*                                                                       40400000
RES      PHGEN 1205,242,2          REACTION TIME PER INPUT              40410000
*                                                                       40420000
GRND     PHGEN 605,122,4           COMPUTE TIME PER INPUT               40430000
*                                                                       40440000
GARB     PHGEN 50250,202,13        GARBAGE IN WS AT SWAP                40450000
*                                                                       40460000
WSIZ     PHGEN 50250,202,14        ACTIVE SIZE OF WS AT SWAP            40470000
         SPACE 2                                                   2219 40480000
QCPU     PHGEN PANICINT,PANICINT,15  CPU-TIME IN APL TU (1/300 SEC)2219 40490000
         SPACE 2                                                   2219 40500000
*                                                                       40510000
LMB30    DC    F'30'                                                    40520000
SCHTEM   DC    4F'0'                                                    40540000
HCSCNT   DC    X'01'               RESIDUE TEN COUNTER GOOD ON M91      40550000
HCSTR    DC    9AL1(1+*-HCSTR),AL1(0)  MODULO TEN TRANS TABLE           40560000
*                                                                       40580000
*                                                                       40590000
         TITLE 'M P X   A N D   S V C   R O U T I N E S       05/11/70' 40600000
*        MULTIPLEXOR CHANNEL ROUTINES                                   40610000
         ENTRY MPXSAVE             FOR CONFINIT SVBASE INITIALIZATION   40620000
MPXSAVE  DS    16F               REGISTER SAVE AREA                     40630000
*                                                                       40640000
*        ROUTINE TO COMPUTE PERTERM OR PUB ADDRESS FROM DEVICE ADDRESS  40650000
*        (MULTIPLEXOR CHANNEL ONLY)                                     40660000
*        FORMAT OF EIGHT BYTE MPXCUTAB ENTRY IS..                       40670000
*        DC    Y(MULTIPLIER)       EITHER PUBENTL OR PERTERML           40680000
*        DC    X'UU'               LOWEST ADRESS FOR CONTROL UNIT       40690000
*        DC    X'UU'               HIGHEST ADDRESS FOR CONTROL UNIT     40700000
*        DC    A(ENTRY ORIGIN FOR THIS CONTROL UNIT)                    40710000
*              THERE ARE SIXTEEN ENTRIES  (256 DIV 16)                  40720000
*                                                                       40730000
MPXINT   MVC   MXOLDPSW(16),IOOLDPSW                                    40740000
         SR    4,4                                                 5991 40750000
         IC    4,MXOLDPSW+3        DEVICE ADDRESS                  5991 40760000
         LA    PTR,X'0F'                                                40770000
         NR    PTR,4                                                    40780000
         XR    4,PTR                                                    40790000
         SRL   4,1                 CONTROL UNIT TIMES 8                 40800000
         A     4,AMXCUT                                                 40810000
         USING MPXCUTAB,4                                               40820000
         MH    PTR,MPXCUTAB                                             40830000
         A     PTR,MPXCUTAB+4                                           40840000
         BZ    IOREJ               NOT OUR INTERRUPT                    40850000
*              TEST FOR DEVICE ADDRESS OUT OF RANGE                     40860000
         CLC   MXOLDPSW+3(1),MPXCUTAB+3                                 40870000
         BH    IOREJ                                                    40880000
         CLC   MXOLDPSW+3(1),MPXCUTAB+2                                 40890000
         BL    IOREJ                                                    40900000
         DROP  4                                                        40910000
         CLI   PTTYPE,0          CHECK FOR INDIRECT ENTRY               40920000
         BNE   MPXA0                                                    40930000
         L     PTR,PTTYPE          TRUE PERTERM OR PUBENT.              40940000
MPXA0    LTR   PTR,PTR             CHECK FOR DUMMY PERTERM.             40950000
         BZ    IOREJ               BRANCH F SO.                         40960000
         SET   UGHSW,MPXIO                                         2217 40970000
         SPACE                                                          40990000
*                                                                       41000000
*        MVT MPXINT.                                                    41010000
*                                                                       41020000
*        MULTIPLEX CODE,  WHEN ENTERED FROM MPXINT,                C020 41030000
*        PRETENDS TO RUN UNDER MOTHER TCB.                         C020 41040000
         SPACE 2                                                   C020 41050000
* 1.     MXCVTTCB IS CVTTCBP                                       C020 41060000
* 2.     CVTTCBP IS 2 RHO TCBMERE                                  C020 41070000
         SPACE 2                                                   C020 41090000
**-------  THE FOLLOWING CODE IS INCLUDED AS A DEBUGGING AID,      C020 41100000
**       SO THAT ANY CATASTROPHIC ERRORS IN THE MULTIPLEX          C020 41110000
**       CODE CAN EASILY BE TRACED TO APL.                         C020 41120000
*                                                                  C020 41130000
* 1.                                                               C020 41140000
*                                                                  C020 41150000
         L     1,CVT                                               C020 41160000
         L     1,CVTTCBP(1)        POINTER TO NEXT AND CURRENT TCB'S.   41170000
         MVC   MXCVTTCB(8),0(1)    SAVED.                               41180000
*                                                                  C020 41190000
* 2.                                                               C020 41200000
*                                                                  C020 41210000
*        POINT TO APL IN CASE WE BLOW IT                           C020 41220000
         MVC   0(4,1),TCBMERE      OUR MOTHER TASK IS NEXT              41230000
         MVC   4(4,1),TCBMERE      AND CURRENT.                         41240000
**                                                                 C020 41250000
**-------  SEE NOTE ABOVE FOR DESCRIPTION OF PRECEEDING CODE       C020 41260000
         SPACE 3                                                   C020 41270000
         MVI   MSERR,0             TURN OFF SIO ERROR MARK              41300000
         MVI   DELZFLG,0           MARK AS MPXINT ENTRY                 41310000
*                                                                       41320000
*        MULTIPLEX CODE STARTS HERE.  IT ACTS LIKE A SUBROUTINE.        41330000
*        DELZFLG IS EXAMINED AT MPXEXIT TO DETERMINE EXIT PATH.         41340000
*                                                                       41350000
*        EXAMINE STATUS BYTES                                           41360000
MSIOERR  TM    STATE,QIEBIT   ENTER HERE WITH STATUS                    41370000
         BZ    MPXA3          NO ENQUED IE                              41380000
         LR    1,PTR                                                    41390000
         BAL   LINK,PRGIE          TIMER EVENT NOT NEEDED               41400000
MPXA3    NI    STATE,255-QIEBIT-DVBUSY                                  41410000
         BAL   1,DEVXCC       COMPUTE DEVICE TYPE BASE REG              41420000
         LR    PXR,6              DEVICE TYPE BASE REGISTER             41430000
         TM    MPXCSW+5,255-IL     IGNORE INCORRECT LENGTH              41440000
         BNZ   MPXCS               ANALYZE CHANNEL STATUS               41450000
*        CHANNEL STATUS IS OK, CHECK DEVICE STATUS                      41460000
         CLI   STATE,SENSING                                            41470000
         BE    MPXA1                                                    41480000
MPXA4    MVC   SAVCSW,MPXCSW       MOVE CSW TO PERTERM                  41490000
         B     MPXA2                                                    41500000
MPXA1    MVC   IODSENSE-IODBUG(1,2),PUSENS  MOVE SENSE BYTE TO IODTAB   41510000
*              ASSUME R2 PRESERVED FROM IOINT.                          41520000
MPXA2    EQU   *                                                        41530000
         SR    SIGR,SIGR         ASSUME NORMAL END                      41540000
         TM    MPXCSW+4,ATT+SM+CUE+UC+UE                                41550000
         BNZ   MXDS1                                                    41560000
         TM    MPXCSW+4,CE+DE                                           41570000
         BNZ   ANALSIG           CHANNEL END,DEVICE END  SIGNE=0        41580000
MXDS1    TM    MPXCSW+4,UC         TEST FOR UNIT CHECK                  41590000
         BNZ   MPXUC                                                    41600000
         TM    MPXCSW+4,UE         TEST FOR UNIT EXCEPTION              41610000
         BNZ   MPXUE                                                    41620000
*        ASSUME 1052 ATTENTION (REQUEST KEY)                            41630000
*        1052-7 UNIT EXCEPTION IS CANCEL KEY                            41640000
UE1052   LA    SIGR,SGINTR         SIGNAL INTERVENTION REQUIRED         41650000
         B     ANALSIG                                                  41660000
MPXUE    L     2,PXUEAD            UNIT EXCEPTION ANALYSIS              41670000
         BR    2                 VARIES WITH DEVICE TYPE                41680000
*                                                                       41690000
*        UNIT CHECK ON MPX DEVICE                                       41700000
MPXUC    UNPK  MXTEM12(3),STATE(2) ISOLATE BOTTOM DIGIT OF STATE        41710000
         CLI   MXTEM12+1,X'F0'+PROCR  (SENSING GIVES = COMPARE)         41720000
         BE    MSERR2              PRESERVE SAVSTAT                     41730000
*        MSERR = 0                 STATUS FROM INTERRUPT                41740000
*        MSERR = 1                 STATUS FROM SIO                      41750000
MSERR    EQU   *+1                 PROG MODIFICATION  $$$$$$$$$$$$$$$$  41760000
         TM    MPXCSW+3,C'*'       SIO SETS TO ONE IF CC 3              41770000
         BO    GEMIN               SIGNAL MINOR ERROR ON CC3            41780000
HIDESTAT MVC   SAVSTAT,STATE       SAVE CURRENT STATE                   41790000
MSERR2   LA    0,PUSENS            COMPUTE SENSE CCW                    41800000
         ST    0,MSENCCW                                                41810000
         MVI   MSENCCW,SENSE                                            41820000
         LA    0,MSENCCW                                                41830000
         LH    1,MPXCHANL          CHANNEL ADDRESS                 5991 41840000
         IC    1,PTUNAD            DEVICE ADDRESS                       41850000
         BAL   LINK,GETSEN        DO SENSE IO                           41860000
         B     MSENFAIL            INDICATE FAILURE OF SENSE IO         41870000
*        START IO INSTRUCTION FOR SENSE IO WAS OKAY                     41880000
         MVI   STATE,SENSING       INDICATE SENSE IO IS CURRENT OP      41890000
         B     MPXEXIT                                                  41900000
*                                                                       41910000
ANALSEN  MVC   STATE,SAVSTAT       RESTORE STATE                        41920000
         IC    2,PUSENS            ANALYZE SENSE BYTE                   41930000
         BAL   LINK,TUSCH         SEARCH TUS                            41940000
*        CHECK FOR SIGNALS WHICH HAVE AN ACTION WHICH IS                41950000
*        INDEPENDENT OF DEVICE TYPE OR STATE                            41960000
*        NOW COMPUTE AN ACTION BASED UPON DEVICE TYPE, STATE, AND       41970000
*              CURRENT SIGNAL                                           41980000
ANALSIG  MVC   ANS1+3(1),STATE                                          41990000
         NI    ANS1+3,X'0F'        CLEAN OUT GARBAGE                    42000000
         L     2,=A(MXSSAG)                                             42010000
         USING MXSSAG,2                                                 42020000
         SR    1,1                                                      42030000
ANS1     IC    1,MXSSAG(SIGR)                                           42040000
         DROP  2                                                        42050000
*        PRECEDING IC DEPENDS UPON THE EXISTENCE OF A USING             42060000
*        STATEMENT FOR MXSSAG.  (IE. DISPLACEMENT MUST BE ZERO.)        42070000
*        IT RESULTS IN THE ADDITION OF THE CURRENT STATE TO THE         42080000
*        SIGNAL BYTE IN SIGR FOR USE AS AN INDEX INTO THE TABLE         42090000
*        CREATED BY THE SSA MACRO CALLS.  ACTION BYTE IS IN R1          42100000
         AR    1,1                                                      42110000
*        ASSUMES THAT ENTRIES ARE WITHIN 512 BYTES                      42120000
         BC    15,ACTBASE(1)                                            42130000
*                                                                       42140000
*                                                                       42150000
MXSIOOK  OI    STATE,DVBUSY        MARK AS STARTED                      42160000
         MPXEXIT                                                        42170000
*                                                                       42180000
*                                                                       42190000
*        1050 UNIT EXCEPTION ANALYSIS                                   42200000
*        ASSUMES UNIT EXCEPTION MUST BE EITHER NEGATIVE RESPONSE TO     42210000
*        POLL OR EOT SENT                                               42220000
UE2702   SR    SIGR,SIGR           ASSUME NORMAL END                    42230000
UE1050   EQU   UE2702                                                   42240000
UEAMBIG  EQU   UE2702                                                   42250000
UE2741   EQU   UE2702                                                   42260000
         CLI   PTRESP,CRD                                               42270000
         BE    ANALSIG             EOT (CRC) IN MESSAGE                 42280000
         L     1,SAVCSW                                                 42290000
         SH    1,=H'8'             LOOK AT FINAL COMMAND                42300000
         LA    0,UECCWIX                                                42310000
         L     2,=A(UECCWI)                                             42320000
UEIB1    CLC   0(1,1),0(2)                                              42330000
         BE    UEIB2                                                    42340000
         LA    2,1(2)              TRY NEXT ENTRY                       42350000
         BCT   0,UEIB1                                                  42360000
GEMIN    LA    SIGR,SGMIN          MYSTERY COMMAND                      42370000
         B     ANALSIG             SIGNAL MINOR ERROR                   42380000
UEIB2    IC    SIGR,TUSSL(2)       FOR ANALSIG                          42390000
         CLI   TUSSL(2),255        WRITE IS SPECIAL CASE                42400000
*        CHECK FOR 2702 ERROR OF ENDING WRITE COMMAND WITH UNIT EXCEPT  42410000
         BNE   ANALSIG                                                  42420000
*        BAD UNIT EXCEPTION, TRY TO CLEAR BY ISSUING READ COMMAND       42430000
         L     0,ADIAG1            RESET RCV CTL BIT IN OLD 2702        42440000
         B     MXSIO                                                    42450000
ACTBASE  EQU   *                                                        42460000
UNDSA    UGH    ,                  AVOID UNDEFINED                      42470000
UNRTC    EQU   UNDSA                                                    42480000
*                                                                       42500000
*        SSA SECAWN,SGTIME,UNDIS                                        42510000
*        SSA PROCR,SGTIME,UNDIS                                         42520000
UNDIS    UGH                       , UNRECOVERABLE DEVICE ERROR         42530000
*                                                                       42540000
*        INTERVENTION REQUIRED DURING READ OPERATION                    42550000
*        SSA READS,SGINTR,UNRINT                                        42560000
UNRINT   LA    BA,PTIBUF                                                42570000
         BAL   LINK,FREEBQ         RELEASE INPUT BUFFERS                42580000
         MVI   PTFBUF+1,EMPTYM     AVOID DOUBLE RELEASE                 42590000
*        SSA WRITES,SGINTR,SETWIRS                                      42600000
*        SSA WRITES,SGTIME,SETWIRS                                      42610000
SETWIRS  SATSUB                    SET ATTENTION.                       42620000
         CLI   PTTYPE,Q103A                                             42630000
         BH    SETIDLE             NOT A 2702 DEVICE                    42640000
         MODNOTE                                                        42650000
*        DIALUP AND FOUR WIRE MODEMS HANDLED THE SAME.                  42660000
         MVI   STATE,WIRS                                               42670000
         LA    0,PREPCCW                                                42680000
         ST    0,PUCCB                                                  42690000
         LA    3,WIRSINT                                                42700000
         BAL   5,SDSUB1            ENQ HIO FOR PREPARE                  42710000
         B     MXSION                                                   42720000
*                                                                       42730000
*        INTERVENTION REQUIRED IN LIRS                                  42740000
*        SSA LIRS,SGINTR,UNLIRINT                                       42750000
UNLIRINT EQU   *                                                  BAM12 42760000
         TM    PUSENS,COMREJ       2703 EC 307067 GIVES COMREJ WHEN     42770000
         BO    SETDROPD            DATA SET READY DROPS                 42780000
         TR    PTCNT,LIRSINC       TRANSLATE TO INCREMENT PTCNT         42790000
         CLI   PTCNT,6             TEST FOR TEN SECONDS, OLD STYLE      42800000
         BNL   SETDROPD            EC 307067 MAKES THIS REDUNDANT       42810000
         B     UNSD                RETRY IN TWO SECONDS                 42820000
*                                                                       42830000
*        TIMER EVENT WHILE IN LIRS                                      42840000
*        SSA LIRS,SGDELZ,UNLIRDZ                                        42850000
UNLIRDZ  TM    STATE,DVBUSY        SETLIRSC VS. UNLIRINT DELAY          42860000
         BZ    SETLIRSC            DELAY WAS FROM UNLIRINT              42870000
         MVI   PTCNT,0               RESET INTERVENTION REQ COUNT       42880000
         CLI   PTTYPE,Q1050        CARRIER DETECT IS UP NOW             42890000
         BL    MPXEXIT             WAIT FOR KEYBOARD TO LOCK            42900000
         MVI   PTRESP,0              FOR UE RESOLUTION AFTER HIO        42910000
         MVI   STATE,LISTEN+DVBUSY  ASSUME OUTPUT IS PENDING, NO HARM   42920000
*              IF IT IS NOT, SO DO HIO ON SPECULATION                   42930000
*        SSA WIRS,SGDELZ,UNHIO                                          42940000
*        SSA LISTEN,SGDELZ,UNHIO                                        42950000
UNHIO    BAL   LINK,HIOSUB         HIO                                  42960000
         B     MPXEXIT                                                  42970000
*                                                                       42980000
*        TALK-DATA DETECTED IN LISTEN STATE                             42990000
*        SSA LISTEN,SGINTR,SETLIRSA                                     43000000
SETLIRSA SATSUB                    SET ATTENTION.                       43010000
*        IN TALK-DATA SEQUENCE.  WAIT FOR DATA BEFORE DOING READ OR WRI 43020000
*        SSA WIRS,SGINTR,SETLIRS                                        43030000
SETLIRS  B     SETLIRSB            BULK IS OUT OF PSEUDO BASE REG RANG  43040000
*                                                                       43050000
*                                                                       43060000
*        ASSUME SIGN ON ATTEMPT HAS ENDED                               43070000
UNKILL   EQU   *                                                        43080000
         BAL   LINK,OFFSUB         PURGE WORKSPACE                      43100000
         CLI   PTTYPE,Q103A                                             43110000
         BH    SETIDL2             NOT 270X                             43120000
*        FOUR WIRE MODEMS AND 103F,3976 MODEMS BEHAVE DIFFERENTLY.      43140000
*        POWER OFF AT TERMINAL DOES NOT CAUSE IBM LIMITED DISTANCE      43150000
*        MODEM TO END READ TYPE COMMAND WITH INTERVENTION REQUIRED.     43160000
*        OPPOSITE IS TRUE FOR 103F,3976.                                43170000
*        SINCE WE KNOW AT THIS POINT THAT NO USER IS SIGNED ON,         43180000
*        WE MAKE THE 103F,3976 ASSUMPTION, WHICH IS THAT INSUFFICIENT   43190000
*        TIME HAS ELAPSED FOLLOWING THE ENABLE TO ALLOW THE MODEM       43200000
*        TO TURN ON, OR ENABLE WAS MISSING.                             43210000
*        REISSUE ENABLE AND SAD.                                        43220000
*        SSA TODROP,SGNE,UNKILL1                                        43230000
*        SSA TODROP,SGTIME,UNKILL1                                      43240000
*        SSA TODROP,SGMIN,UNKILL1                                       43250000
*        SSA TODROP,SGINTR,UNKILL1                                      43260000
*        SSA TODROP,SGDELZ,UNKILL1                                      43270000
UNKILL1  CLI   STATE,READS         IN THE READ STATE, PTFBUF POINTS     43280000
         BNE   *+8                 TO SAME CHAIN AS PTIBUF              43290000
         MVI   PTFBUF+1,EMPTYM     PREVENT DOUBLE RELEASE               43300000
         L     10,=A(MXDCCC)       DISCONNECT HW OR DIALUP LINE         43310000
         BR    10                  RETURNS TO MXSION                    43320000
*                                                                       43330000
*        2741 ATTENTION IN LISTEN STATE                                 43340000
*        SSA LISTEN,SGNE,UN2741BF                                       43350000
UN2741BF SATSUB                    SET ATTENTION AND ENTER IDLE STATE   43360000
*                                                                       43370000
*        SSA WIRS,SGNE,SETIDLE                                          43380000
*        SSA WIRS,SGTIME,SETIDLE                                        43390000
*        SSA WIRS,SGMIN,SETIDLE                                         43400000
*        SSA LIRS,SGNE,SETIDLE                                          43410000
*        SSA LIRS,SGMIN,SETIDLE                                         43420000
*        SSA LIRS,SGTIME,SETIDLE                                        43430000
*        SSA LISTEN,SGTIME,SETIDLE                                      43440000
*        SSA LISTEN,SGMIN,SETIDLE                                       43450000
*        SSA IDLE,SGNE,SETIDLE                                          43460000
*        SSA IDLE,SGMIN,SETIDLE                                         43470000
*        SSA IDLE,SGDELZ,SETIDLE                                        43480000
*        SSA IDLE,SGTIME,SETIDLE                                        43490000
SETIDLE  MVI   STATE,IDLE                                               43500000
         CLI   PTFBUF+1,EMPTYM                                          43510000
         BNE   UNWZ                WRITE TO TERMINAL                    43520000
         B     SETIDL2                                                  43530000
*                                                                       43540000
UNSOP    MVC   SAVSTAT,STATE                                            43550000
         MVI   STATE,PROCR         AWAIT OPERATOR INTERVENTION          43560000
         B     MPXEXIT                                                  43570000
*                                                                       43580000
*        INDIRECT ENTRY TO MULTIPLEXOR END OF READ (TYI) ROUTINE        43590000
*        SSA READS,SGNE,UNRZA                                           43600000
UNRZA    L     10,=A(UNRZ)                                              43610000
         BR    10                  REAL END OF READ IS UP IN THE SKY    43620000
*                                                                       43630000
*        SSA IDLE,SGINTR,UNSAT                                          43640000
UNSAT    SATSUB                    1052,SET ATTENTION.                  43650000
         B     MPXEXIT                                                  43660000
*                                                                       43670000
*        INTERVENTION REQUIRED IN PROCR STATE                           43680000
*        SSA PROCR,SGINTR,UNPINT                                        43690000
UNPINT   EX    0,ANALSEN           RESTORE STATE FROM SAVSTAT           43700000
         B     UE1052                                                   43710000
*                                                                       43720000
*        NON-UNIT CHECK INTERRUPT IN PROCRASTINATE STATE.               43730000
*        A SIO FOR SENSE COMMAND OR EXCP ACTIVITY WAS PROCRASTINATED.   43740000
*        SSA PROCR,SGNE,UNPRO                                           43750000
*        SSA PROCR,SGMIN,UNPRO                                          43760000
*        SSA PROCR,SGDELZ,UNPRO                                         43770000
UNPRO    CLI   STATE,SENSING                                            43780000
         BE    ANALSEN             SENSE IO WAS FINISHED                43790000
         TM    STATE,SENREQ        RETRY SIO OF SENSEIO NOW             43800000
         BO    MPXUC               OLD INT WAS CE,UC  SENSE COM STATUS  43820000
          B     UNPRO1                                             BAM4 43850000
*                                                                       43900000
*        READ RETRY -- ALTER 2741 POLLING SEQUENCE TO PRINT RESEND      43910000
*        SSA READS,SGMIN,UNRRT                                          43920000
*        SSA READS,SGDELZ,UNRRT                                         43930000
UNRRT    MVC   KRC2741(1),PXRSTA   CHARACTER SET DEPENDENT              43940000
         MVI   KRC2741+2,LRSTXT                                         43950000
         BAL   LINK,MXRCCC         RECOMPUTE CHAIN                      43960000
         MVC   KRC2741(4),KRC2741A  RESTORE 2741 CCW PARAMETERS         43970000
         B     MXSION              RETRY READ                           43980000
*                                                                       43990000
*        MINOR ERROR WHILE WRITING TO TERMINAL                          44000000
*        SSA WRITES,SGMIN,UNWCNT                                        44010000
UNWCNT   TR    PTCNT,ERINC         INCREMENT ERROR COUNT                44020000
         CLI   PTCNT,0             ERINC COUNTS MOD RETRY COUNT         44030000
         BE    UNWFAIL                                                  44040000
*                                                                       44050000
*        RETRY ON TYPEWRITER                                            44060000
*        SSA WRITES,SGDELZ,UNRWC                                        44070000
UNRWC    EQU   *                                                        44080000
         CLI   MSERR,1             TEST FOR ERROR FROM SIO              44090000
         BNE   MXSIOQ              WAS I O INTERRUPT, RETRY NOW         44100000
         B     UNSD                DELAY BEFORE NEXT SIO                44110000
*                                                                       44120000
*        ANOTHER ITERATION ... THIS ONE FOR 2703 EC 307050              44130000
*        ENABLE ENDS WITH TIME OUT IF CARRIER DETECT DOES NOT           44140000
*        COME UP WITHIN 28 SECONDS OF ANSWER.                           44150000
*        WE END UP AT UNKILL IF THIS HAPPENS.                           44160000
*                                                                       44170000
*        SSA READS,SGTIME,UNRTIME                                       44180000
UNRTIME  CLI   PTCCW1,ENABLE                                            44190000
         BNE   UNRTIM1             FIRST COMMAND WAS NOT ENABLE         44200000
*                                                                       44210000
*        TIME OUT IN READ STATE ON NON DIAL UP LINES ...                44220000
*        MAY HAPPEN WHEN A TERMINAL HAS BEEN SWITCHED OFF, BUT          44230000
*        NO INTERVENTION REQUIRED IS INDICATED.                         44240000
*        TREAT AS INTERVENTION REQUIRED.                                44250000
*                                                                       44260000
         TM    IOB2,Q4WMDM                                              44270000
         BO    UNQ4WDIE                                                 44280000
         LA    1,PTCCW1+8                                               44290000
         C     1,SAVCSW            WAS TIMEOUT ON COMMAND IN PTCCW1 --  44300000
         BE    UNRINT              GET TO UNKILL IF SO.                 44310000
*                                                                       44320000
*        TIMEOUT IN READ STATE, MUST BE PTTYPE=QAMBIG                   44330000
UNRTIM1  LA    1,PTCCW3                                                 44340000
         MVI   PTCCW1,1            FOR UNKILL LINE ADAPTER CHECK.       44350000
         C     1,SAVCSW                                                 44360000
         BNE   UNRINT              ORDINARY TIMEOUT, HANGUP LINE        44370000
*        READ  RESPONSE TIMED OUT, CHANGE POLLING SEQ                   44380000
*  UNRTIME ATTEMPTS TO RESOLVE TYPE OF A NEWLY CONNECTED TERMINAL       44390000
*        WHICH HAS NOT YET RESPONDED TO A POLL.  UEAMBIG WILL           44400000
*        CONTINUE TO POLL UNTIL THE AMBIGUITY OF TERMINAL TYPE          44410000
*        (1050 VS. 2741) IS RESOLVED.                                   44420000
         CLI   PTCCW1+7,1                                               44430000
         BE    *+8                 PREV POLLING SEQ WAS 2741. TRY 1050  44440000
UNRRTA   MVI   PTTYPE,Q2741        POLL WITH SINGLE CRC                 44450000
         BAL   LINK,MXRCCC                                              44460000
         MVI   PTTYPE,QAMBIG       FOR INTERRUPT ANALYSIS               44470000
         MVI   PTCCW1+8,X'02'      ALLOW TIMEOUT                        44480000
         B     MXSION              WITH ALTERNATE POLLING SEQUENCES     44490000
*                                                                       44500000
*                                                                       44510000
*        NORMAL END OF WRITE MPX                                        44520000
*        SSA WRITES,SGNE,UNWZ                                           44530000
UNWZ     L     8,=A(MXWCCC)                                        P056 44550000
         CLI   SHUTDOWN,0          IS SHUTDOWN IN PROGRESS?        P056 44560000
         BCR   8,8 BER             NO, COMPUTE WRITE CCW CHAIN.    P056 44570000
         CLI   PTTYPE,QAMBIG       ARE WE STILL SIGNED ON?         P056 44580000
         BCR   7,8 BNER            YES, COMPUTE WRITE CCW CHAIN.   P056 44590000
         OI    IOB2,LVIDLEM        END OF DISABLE,FLAG AS DOWN     P056 44600000
         B     MPXEXIT             AND LEAVE IT THAT WAY.          P056 44610000
*        ISSUE START I/O ON MPX CHANNEL                                 44680000
MXSIOQ   EQU   *                                                        44720000
MXSION   L     0,PUCCB             CCW ADDRESS                          44770000
MXSIO    MVI   PTRESP,0            FOR DEVICES WITH A PERTERM           44780000
MXSIOE   EQU   *                   NON-PERTERM ENTRY POINT              44790000
         N     0,KX24M             CLEAR HIGH ORDER BYTE                44800000
         LH    1,MPXCHANL          CHANNEL ADDRESS                 5991 44810000
         IC    1,PTUNAD          DEVICE ADDRESS                         44820000
MXSIO2   BAL   5,SIOSUB                                                 44830000
         B     MXSIOOK        SIO OKAY                                  44840000
         MVC   MPXCSW(8),CSW       STATUS WAS STORED                    44850000
         CLI   MPXCSW+4,BSY+DE     BUSY + DEVICE END                    44860000
         BE    MXSIO2              RETRY SIO IMMEDIATELY                44870000
         TM    MPXCSW+4,BSY        BUSY                                 44880000
         BO    UNSOP                                                    44890000
         MVI   MSERR,1             INDICATE SIO STATUS,NOT INTERRUPT    44900000
         B     MSIOERR                                                  44910000
*                                                                       44960000
*        NON-UNIT CHECK INTERRUPT IN PROCR STATE NOT FROM LIRS STATE    44970000
UNPRO1   EQU   *                                                  BAM4A 45010000
         EX    0,ANALSEN           RESTORE STATE FROM SAVSTAT           45020000
         B     MXSION                                                   45030000
*                                                                       45050000
*        TRIED THREE TIMES IN WRITE STATE                               45060000
UNWFAIL  MVI   PTCNT,0             CLEAR ERROR COUNT                    45070000
         L     1,PUCCB                                                  45080000
         CLI   0(1),DISABLE                                             45090000
         BE    UNRWC               INFINITE RETRY COUNT ON DISABLE      45100000
         CLI   PTRESP,CRN          1050 WITH RCV ALARM, MAYBE           45110000
         BE    UNRWC               NEGATIVE RESPONSE TO ADDRESSING      45120000
         CLI   0(1),X'17'                                          2223 45130000
         BE    UNRWC                                               2223 45140000
         B     UNWZ                IGNORE ERRORS                        45150000
*                                                                       45160000
*                                                                       45170000
SETIDL2  TM    IOB2,LVIDLEM        LEAVE IDLE FLAG                      45180000
         BO    MPXEXIT             LEAVE 2703 COMMAND FREE              45190000
         TM    ACTIVE,INWAITM                                           45200000
         BZ    SETIDL4                                                  45210000
         TM    IOB1,COPYRM                                              45220000
         BO    SETIDL4             NOT REALLY AWAITING INPUT            45230000
         BAL   LINK,MXRCCC         ENTER READ STATE                     45240000
         B     MXSIOQ              UNLOCK KEYBOARD                      45250000
SETIDL4  MVI   STATE,IDLE                                               45260000
SETIDL5  CLI   PTTYPE,Q103A        ENTER HERE TO PRESERVE QIEBIT        45270000
         BH    MPXEXIT             NOT A 2702 DEVICE                    45280000
         MODNOTE                                                        45290000
*        MODEMS TREATED LIKE DIALUP.                                    45300000
         XI    STATE,IDLE-LISTEN   STATE IS LISTEN                      45310000
         LA    0,PREPCCW                                                45320000
         B     MXSIO                                                    45330000
*                                                                       45340000
*        ABONDON A FOUR WIRE MODEM DUE TO MYSTERY TROUBLE               45350000
UNQ4WDIE MVI   STATE,IDLE          MARK DEAD                            45360000
         B     MPXEXIT                                                  45370000
*                                                                       45380000
*        SENSE IO DIDN'T WORK, RETRY AT NEXT INTERRUPT                  45390000
MSENFAIL MVI   STATE,PROCR+SENREQ                                       45400000
*                                                                       45410000
*        DELAY FURTHER RETRY ATTEMPTS ON THIS DEVICE FOR LESS THAN TWOS 45420000
UNSD     LA    5,MPXEXIT           SET 2 SEC DELAY AND EXIT TO MPX      45430000
SDSUB    LA    3,TWOSEC            STANDARD DELAY                       45440000
SDSUB1   LR    2,PTR               EVENT WILL BE SGDELZ                 45450000
         OI    STATE,QIEBIT        FOR PURGE AT MSIOERR                 45460000
         B     ENQIE                                                    45470000
*                                                                       45480000
*        ATTENTION SETTING ROUTINE FOR 270X DEVICES                     45490000
SATSUB   TM    IOB1,COPYRM+NSIGNM  CHECK FOR SPECIAL CASE               45500000
         BNZ   SAT3                AVOID NORMAL ATTN                    45510000
         TM    ACTIVE,ATTENM       CHECK FOR ATTENTION ALREADY SET.     45520000
         BZ    SAT6                BRANCH IF NOT.                       45530000
         BAL   5,SHCPUSUB          SET CPU LIMIT TO ONE SECOND          45540000
*                                  OF CPU TIME AND THEN FORCE ATTENTION 45550000
SAT6     CLI   DESBYTE,0           AVOID DESUSPEND IF TERMINAL IS IN    45560000
         BE    SAT5                TRAWAIT AND SENDING TO LOG           45570000
         MVI   DESBYTE,X'FF'       MARK AS NO MESSAGES                  45580000
         NI    ACTIVE,LOCKM                                             45600000
         PTSET ACTIVE                                                   45640000
         OI    ACTIVE,ATTENM                                            45650000
         MVI   MISCB,0                                                  45660000
         PTSET MISCB                                                    45670000
SAT5     EQU   *                                                        45680000
         MVI   RESCH,1             FORCE ENTRANCE TO GENERAL EXIT       45700000
*        IF TERMINAL WAS TRYING TO SEND A MESSAGE (TRAWAIT SET),        45720000
*        PTIBUF POINTS AN UNRELEASED BUFFER STRING.  NEXT TYI WILL      45730000
*        RELEASE.                                                       45740000
*        IF PTRBUF POINTS TO AN OUTPUT LINE, RECHAIN PTRBUF BUFFERS TO  45750000
*        TOP OF PTFBUF CHAIN FOR RELEASE OR RETRY.                      45760000
SAT8     CLI   PTRBUF+1,EMPTYM                                          45770000
         BE    SAT7                EASY TO PREFIX IOTA ZERO             45780000
         L     BA,PTRBUF           EVENTUAL FIRST BUFFER                45790000
         USING PERBUF,BA                                                45800000
         LR    0,BA                                                     45810000
         B     *+8                                                      45820000
         L     BA,PBTIC            SEARCH FOR END OF LIST               45830000
         TM    PBFLAG,LISTZ                                             45840000
         BZ    *-8                                                      45850000
         MVC   PBTIC,PTFBUF                                             45860000
         CLI   PTFBUF+1,EMPTYM                                          45870000
         BE    *+8                 PRESERVE LISTZ BIT                   45880000
         NI    PBFLAG,255-LISTZ                                         45890000
         DROP  BA                                                       45900000
         ST    0,PTFBUF            SET TO OLD PTRBUF                    45910000
         MVI   PTRBUF+1,EMPTYM                                          45920000
SAT7     TM    IOB2,RECMM          SETIDLE WILL RETRY                   45930000
         BCR   1,LINK  BOR         THE FORMER PTRBUF LINE               45940000
         LA    BA,PTFBUF           RELEASE OUTPUT BUFFERS               45950000
         B     FREEBQ                                                   45960000
SAT3     TM    MISCB,NOWSM         ATTN BEFORE SIGN-ON TEST             45970000
         BO    UNKILL              FOR THE NOVICE USER                  45980000
         B     SAT8                COPY MODE, CLEANUP TYPEWRITER BUFFER 45990000
*        THIS ASSUMES COPY WILL END EVENTUALLY                          46000000
*                                                                       46010000
*        PURGE SVDEL TIMER EVENT.                                       46020000
SATPSUB  TM    MISCB,CLOKWAIT      SEE IF SVDEL EVENT PENDING.          46030000
         BCR   8,LINK              NRAMCH OUT IF  NOT.                  46040000
         L     1,KIETCLOK          HI ORDER BYTE FOR PURGE              46050000
         OR    1,PTR               IEBASE SETTING                       46060000
         NI    MISCB,255-CLOKWAIT  TURN OFF CLOCK WAIT                  46070000
         BNZ   PRGIE               PURGE EVENT                          46080000
         NI    ACTIVE,255-MISCM    NO BITS ON IN MISCB, RESET MISCM     46090000
         B     PRGIE               PURGE EVENT.                         46100000
*                                                                       46110000
*        270X LINE HAS DROPPED.  LEAVE COMMAND FREE UNTIL DISCONNECT TI 46120000
SETDROPD MVI   STATE,IDLE          MARK IDLE                            46130000
         L     10,=A(BOUNSUB)      SET FORCM TO INHIBIT SVTYI           46140000
         BALR  8,10                                                     46150000
         TM    IOB2,BOUNCM         ZERO IF NOWS AND NSIGNM              46160000
         BZ    UNKILL              YES, DROP LINE NOW                   46170000
         OI    IOB2,LVIDLEM        FLAG FOR SVTYO                       46180000
         MVI   RESCH,1             CAUSE A RESCHEDULE              C023 46190000
         B     MPXEXIT                                                  46200000
*                                                                       46210000
*        LIRS STATE IS USED TO AWAIT DATA CARRIER DETECT DURING TALK-   46220000
*        DATA SEQUENCE                                                  46230000
SETLIRSB MVI   STATE,LIRS                                               46240000
         MVI   PTCNT,0             WILL USE TO MEASURE TEN SECONDS      46250000
         LA    0,PREPCCW           PREPARE FOR 1050                     46260000
         CLI   PTTYPE,Q1050                                             46270000
         BE    *+8                 USE PREPARE COMMAND TO DETECT TALKZ  46280000
         LA    0,LIRS2741          2741 POWERON RESET RECOVERY          46290000
         ST    0,PUCCB                                                  46300000
SETLIRSC BAL   5,SDSUB             ENQ TWOSEC MPX EVENT                 46310000
         B     MXSION                                                   46320000
*        SEQUENCE FOR 2741 IS..                                         46330000
*        CCW   INHIBIT,CREP,CC+SLI+SKIP,INFINITY                        46340000
*        CCW   WRITE,KCRD,SLI,1                                         46350000
*                                                                       46360000
*                                                                       46370000
*        LOG AND IGNORE MPX CHANNEL PROGRAM CHECKS (IN CHANNEL PROG)    46390000
MPXPC    MVC   SAVCSW,MPXCSW       SAVE BAD CSW                         46400000
         UNPK  MPXCTA(3),PTUNAD(2)                                      46410000
         TR    MPXCTA(2),HEXTAB                                         46420000
         MVI   MPXCTA+2,ZCR        RESTORE CARRIAGE RETURN              46430000
         LA    3,MPXPCT            POINT TO TO COUNT                    46440000
         BAL   LINK,NUINS          EDIT AND STACK                       46450000
         B     MPXEXIT             DON'T TOUCH BAD DEVICE               46460000
*                                                                       46510000
MPXCS    TM    MPXCSW+5,255-IL-PCICSW  SORT OUT PCI AND OTHERS          46520000
         BNZ   MPXPC               NASTY BITS ARE ON                    46530000
         TM    MPXCSW+4,CE         CHANNEL END TEST                     46540000
         BO    MPXA4               IGNORE PCI                           46550000
         OI    STATE,DVBUSY                                             46560000
         CLI   STATE,READS+DVBUSY  PCI OUTSIDE READ STATE               46570000
         BNE   MPXEXIT             IGNORE FOR NON READ STATE            46580000
*        PCI ON MULTIPLEXOR READ                                        46590000
*        ALLOCATE ONE MORE BUFFER AND TRANSLATE ONE BUFFER              46600000
MREADPCI MVI   MPXCSW,TIC            SEE IF RACE IS ALREADY LOST BY     46610000
         L     2,MPXCSW              CHECKING FOR DISCARD BEING         46620000
         SH    2,=H'8'             CURRENT BUFFER                       46630000
         C     2,RNBCON+4                                               46640000
         BE    MXRPCI1             THE RACE IS LOST                     46650000
         BAL   LINK,GETBUF         GET ANOTHER INPUT BUFFER             46660000
         B     MRPCI3              NO BUFFER AVAILABLE                  46670000
         BAL   LINK,RNEWB3         INITIALIZE NEW BUFFER BEFORE TIC     46680000
         BAL   LINK,RNEWBUF        LINK TO CHAIN                        46690000
MRPCI2   EQU   *                                                        46700000
         C     2,PTCCW3                                                 46710000
         BE    MPXEXIT             NOTHING TO TRANSLATE YET             46720000
         CLI   PTTYPE,QAMBIG                                            46730000
         BE    MPXEXIT             NO TRANSLATE TABLE                   46740000
         BAL   LINK,RTRBUF         TRANSLATE ONE BUFFER                 46750000
         B     MPXEXIT                                                  46760000
MRPCI3   L     1,MSPCI2            COUNT THE NUMBER OF NO BUFFER        46780000
         LA    1,1(1)              AVAILABLE AT PCI CONDITIONS          46790000
         ST    1,MSPCI2            FOR DEBUGGING AND EVALUATION USE     46800000
         B     MRPCI2              TRANSLATE THIS ONE                   46850000
MXRPCI1  LA    BA,PTIBUF           DISCARD INPUT BUFFERS                46860000
         BAL   LINK,FREEBQ                                              46870000
         B     MPXEXIT             AWAIT FINAL INTERRUPT                46880000
*                                                                       46890000
*        RTRBUF IS USED TO TRANSLATE A FILLED BUFFER TO ZSYMBOLS.       46900000
*        EARLY 2741 LINE FEED DETECTION IS DONE TO AVOID RACE           46910000
*        CONDITION BETWEEN UNRZ27 AND INLINE.  RTRBUF ADVANCES PTFBUF   46920000
*        BEFORE TRANSLATING AND EXITS WITH R4=PTFBUF                    46930000
         USING PERBUF,4                                                 46940000
RTRBUF   L     4,PTFBUF                                                 46950000
         L     4,PBTIC             POINT TO UNTRANSLATED BUFFER         46960000
         ST    4,PTFBUF                                                 46970000
         L     BA,TYITAD                                                46980000
         TR    PBSTAR,0(BA)        TRANSLATE INPUT                      47040000
         MVI   PBFLAG,FILLBIT      THIS IS FOR INLINE                   47050000
         MVI   PBLAST,ZBFZ         THIS IS FOR INLINE                   47060000
         CLI   PTTYPE,Q2741                                             47070000
         BCR   2,LINK  BHR         NOT 2741 OR TS41                     47080000
         CLI   PBLAST-1,ZEOB       THIS IS EARLY 2741 LF DETECTOR       47090000
         BCR   7,LINK   BNER       NOT EOB                              47100000
*        CHANNEL END WILL ARRIVE SHORTLY, BUT INLINE MAY BE CHURNING    47110000
         CLI   PBLAST-2,ZCR                                             47120000
         BCR   8,LINK   BER        FOUND CARRIAGE RETURN                47130000
         MVI   PBLAST-1,ZLF        TELL INLINE AND UNRZ27               47140000
         BR    LINK                                                     47150000
         DROP  4                                                        47160000
*                                                                       47170000
         SVINT SA                                                       47180000
         PRINT NOGEN                                                    47190000
SVCTAB   DCY   SVILG               0 RESERVED                BAM22      47200000
         DCY   SVTYO               1 TYO                                47210000
         DCY   SVTYI               2 TYI  (INPUT TO INTERPRETER)        47220000
         DCY   SVDSZ               3 END OF DIRECTORY SEARCH            47240000
         DCY   SVINIT              4 NORMALLY QUANTUM END, INIT IS TEMP 47250000
         DCY   SVLEMP              5 LOAD EMPTY WORKSPACE               47260000
         DCY   SVTRAN              6 TRANSMIT A MESSAGE                 47270000
         DCY   SVILG               7 RESERVED                BAM22      47280000
         DCY   SVSDREQ             8 REQUEST DIRECTORY OPERATION        47290000
         DCY   SVATOFF             9 TURN OFF ATTENTION BIT             47390000
         DCY   SVRAPE              10 REQUEST ANOMOLOUS PROTECT EXCEPTI 47400000
         DCY   SVOFF               11 SIGN OFF AND DIAL DISCONNECT      47420000
         DCY   SVBROAD             12 BROADCAST MESSAGE                 47430000
         DCY   SVSOOK              13 SIGN ON OKAY                      47440000
         DCY   SVLIBZ              14 END OF )LIB COMMAND               47450000
         DCY   SVSOM               15 )HI SETS SIGN ON MESSAGE          47460000
         DCY   SVRECM              16 RECEIVE MESSAGES                  47470000
         DCY   SVEXITPC            17 RETURN FROM PCSUB                 47480000
         DCY   SVDEL               18 DELAY FOR A WHILE                 47490000
         DCY   SVBOUNC             19 FORCE SIGN OFF OF SOME TERMINAL   47500000
         DCY   SVRESET             20 ATTEMPT TO RESTART 2702 LINE      47510000
         DCY   SVTIME              21 TIME OF DAY (CP/67 ONLY)          47520000
         DCY   SVOFFH              22 SIGN OFF HOLD                     47530000
         DCY   SVBREL              23 INPUT BUFFER RELEASE              47540000
         DCY   SVEOD               24 INITIATE SYSTEM SHUTDOWN          47550000
         DCY   SVLOG               25 MESSAGE TO LOG TRANSMISSION       47560000
         PRINT GEN                                                      47690000
SVMAX    EQU   (*-SVCTAB-2)/2      MAXIMUM SVC CODE                     47700000
SVILG    OI    SVOLDPSW+5,X'C0'    CAUSE PROGRAM CHECK             P035 47710000
         B     SVEXIT              AFTER EXIT                           47720000
STYOBAD  EQU   SVILG               MAJOR TYO TROUBLES                   47730000
*                                                                       47740000
         USING M,PXR                                                    47750000
SVTYI1   LA    8,SETIDL2           TO INITIATE READ                     47760000
         BAL   LINK,INITMOP        POKE MPX CODE                        47770000
         B     QUEND               END OF TYI INITIATION                47780000
*                                                                       47790000
*        SET OUTWAIT OR BUFFWAIT                                        47800000
SETBUFWQ CLI   PTFBUF+1,EMPTYM     OUTWAIT IS PREFERRED BECAUSE TERM-   47810000
         BNE   SETOUTW                                                  47820000
*                                  WHEN WAIT IS BROKEN                  47830000
*        PLACE A TERMINAL IN BUFFER WAIT                                47840000
SETBUFW  ST    PTR,STBFW1                                               47850000
         L     1,BUFWLEND          ADDRESS TO MAKE INSERTION            47860000
         C     1,BFLEMAX                                                47870000
         BH    BACK6               BUFFER WAIT QUEUE OVERFLOW           47880000
         MVC   0(4,1),STBFW1+1     MOVE 3BYTE PTR+EMPTYM TO QUEUE       47890000
         AH    1,=H'3'             INCREASE END POINTER                 47900000
         ST    1,BUFWLEND                                               47910000
         OI    MISCB,BUFFWAIT                                           47920000
         OI    ACTIVE,MISCM                                             47930000
         B     BACK6               BACKUP OVER SVC AND LOAD             47940000
SETOUTW  OI    ACTIVE,OUTWAITM     WAIT FOR SOEMP THIS TERM             47950000
*                                                                       47960000
BACK6    LH    0,=H'-6'            RE-ISSUE SVC & PRECEEDING LA         47970000
SVWAIT2  TM    SVOLDPSW+4,X'80'    IF 4-BYTE SVCC OR EXECUTED SVC,      47980000
         BZ    *+8                 BACK UP ANOTHER 2 BYTES              47990000
         AH    0,=H'-2'                                                 48000000
         A     0,SVOLDPSW+4        ADJUST IAR IN SVC OLD PSW            48010000
         ST    0,SVOLDPSW+4                                             48020000
         B     QUEND               EXIT TO SCHEDULER                    48030000
*                                                                       48040000
*        INITMWR IS A SUBROUTINE TO INITIATE A MULTIPLEXOR WRITE        48050000
*        OPERATION.  IT IS CALLED BY SVC ROUTINES WHICH HAVE CALLED     48060000
*        TYOINS TO ATTACH OUTPUT BUFFERS TO A TERMINAL.  IF             48070000
*        DEVICE STATE IS IDLE (UNLIKELY EXCEPT FOR 1052) MULTIPLEXOR    48080000
*        CODE IS CALLED AS A SUBROUTINE TO DO A SIO.  OTHERWISE A HIO   48090000
*        WILL BE ISSUED TO END THE PREPARE COMMAND.                     48100000
INITMWR  L     8,=A(MXWCCC)        MULTIPLEX ENTRY POINT                48110000
*        ENTER AT INITMOP FOR NON-WRITE FUNCTIONS IN MPX                48120000
INITMOP  CLI   STATE,IDLE                                               48130000
         BE    INITM1              GET INTO MULTIPLEX COE               48140000
         CLI   STATE,DVBUSY+LISTEN   HIO ONLY FOR PREPARE               48150000
         BCR   7,LINK              PRESENT CCW WILL END AUTOMATICALLY   48160000
HIOSUB   MVI   PUCCB,X'FF'         SET HIO FLAG                         48170000
         LH    1,MPXCHANL          CHANNEL ADDRESS                 5991 48180000
         TCH   0(1)                AVOID HIO ON BURST MODE OPERATION    48190000
         BC    2,*-4               BECAUSE IT IS PROBABLY FOR ANOTHER   48200000
         IC    1,PTUNAD                                                 48210000
FREEH    MVC   CSW,ZERO                                                 48220000
         ST    LINK,CSW            LINK IS USEFUL ANALYSIS AID          48230000
         HIO   0(1)                                                     48240000
         TM    CSW+4,CUB2702       270X REJECTED HIO                    48250000
         BO    FREEH               HIT IT AGAIN.                        48260000
         BAL   3,IODADV            RECORD HIO IN IODBUG TABLE           48270000
         USING IODBUG,2                                                 48280000
         MVI   IODHIO,X'FC'        HIO FLAG                             48290000
         DROP  2                                                        48300000
         BR    LINK                2702 IS STILL BUSY                   48310000
*        STATE IS IDLE, ENTER MPX CODE                                  48320000
INITM1   SVTOMX     ,              SETUP FOR MPXEXIT                    48330000
         BR    8                   ENTER MULTIPLEX CODE                 48340000
*                                                                       48350000
*                                                                       48360000
*                                                                       48370000
*        ROUTINE TO CHANGE OUTPUT CCW CHAIN TO INPUT CCW CHAIN          48380000
*        READ CCW CHAINS                                                48390000
*                                                                       48400000
*                                                                       48410000
MXRCCC   ST    LINK,MXTEM12        SAVE RETURN                          48420000
         LA    BA,PTIBUF           RELEASE PREVIOUS INPUT BUFFER        48430000
         BAL   LINK,FREEBQ                                              48440000
         BAL   1,DEVXCC                                                 48450000
         BAL   LINK,GETBUF         FIRST INPUT BUFFER                   48460000
         B     RNOBUF                                                   48470000
*        BA POINTS TO BUFFER                                            48480000
         ST    BA,PTIBUF           FOR INLINE EVENTUALLY                48490000
         LA    1,PTCCW2                                                 48500000
         BAL   LINK,RNEWB1         LINK BUFFER INTO COMMAND CHAIN       48510000
         USING PERBUF,BA                                                48520000
         MVI   PBCCW,X'0A'         1052 READ KEYBOARD                   48530000
         LA    0,PTCCW2                                                 48540000
         ST    0,PTFBUF            FOR RTRBUF FIRST CALL                48550000
         MVI   STATE,READS                                              48560000
MXRCC0   L     2,PXMXR-PERDEVX(6)  SPECIAL ROUTINE ADDRESS              48610000
         EX    0,0(2)              LOAD R2 OR BRANCH                    48620000
MXRCC1   EQU   *                   COMMON TO ALL 270X DEVICES           48630000
         MVI   PTCCW2+4,DC                                              48640000
         STC   2,PTCCW2            BYTE 3 = COMMAND CODE                48650000
         SRL   2,8                                                      48660000
         STC   2,PTCCW1+7          BYTE 2 = COUNT                       48670000
         SRL   2,8                                                      48680000
         L     3,INPCON            =A(256*INPOLL)                       48690000
         SRDL  2,8                 BYTE 1 = PTCCW1 OP CODE              48700000
         AR    2,3                 BYTE 0 = INPOLL DISPLACEMENT         48710000
         ST    2,PTCCW1                                                 48720000
         MVI   PTCCW2+5,FORCELF    FOR UNRZ26 2741 LF DETECTION         48730000
         LA    BA,PTCCW1           INITIAL CAW                          48740000
MXRCC2   ST    BA,PUCCB                                                 48750000
         BAL   LINK,CORTIME        TIME FOR HISTOGRAMS                  48760000
         ST    0,PTMTIME                                                48770000
MXRCC4   L     LINK,MXTEM12                                             48780000
         BR    LINK                                                     48790000
*                                                                       48800000
MXR2741  L     2,KRC2741                                                48810000
MXR1050  L     2,KRC1050                                                48820000
MXRAMBIG B     *+4                                                      48830000
         L     2,KRCAMW            ASSUME NON-ENABLE CASE               48840000
         CLI   PTCCW1,DISABLE      UNLESS PREIOUS COMMAND WAS DISABLE   48850000
         BNE   MXRCC1                                                   48860000
         L     2,KRCAME            WE NEED AN ENABLE                    48870000
         CLI   SHUTDOWN,0          MAYBE WE SHOULD LEAVE LINE DISABLED  48940000
         BE    MXRCC1              NO, ENABLE THIS LINE                 48950000
         OI    IOB2,LVIDLEM        FLAG LINE IDLE FOR OPFNS REFERENCE   48960000
         B     MPXEXIT             YES, SYSTEM IS GOING DOWN            48970000
MXR1052  B     MXRCC2              DO NOT OPTIMIZE, THIS IS EXECUTED    49140000
         DROP  BA                                                       49150000
*        DELAY READ BECAUSE NO BUFFER AVAILABLE                         49260000
RNOBUF   MVI   PTFBUF+1,EMPTYM     KILL POINTER TO NON-BUFFER           49270000
RNOBUF1  MVI   STATE,LISTEN                                             49280000
         BAL   5,SDSUB             WAIT TWO SECONDS FOR BUFFER          49290000
         LA    BA,PREPCCW          LOAD PREPARE WHILE WE WAIT FOR BUFFR 49300000
         B     MXRCC2                                                   49310000
*                                                                       49320000
KSOHK    L     1,SVOFLIM           KILL SIGN OFF HOLD KILL              49330000
         OR    1,PTR                                                    49340000
         B     PRGIE               IESOHK MAY BE ENQ D FOR TERMINAL     49350000
*                                                                       49370000
*        SIGN OFF WITH HOLD                                             49380000
         USING SVOFFH,10                                                49390000
SVOFFH   TM    IOB2,LOEXP          EXPRESS LINE )OFF HOLD IGNORED       49400000
         BO    SVOFF0              TRNSMUTE TO )OFF                     49410000
         CLI   SHUTDOWN,0          AFTER SHUTDOWN, TRANSMUTE ANY        49420000
         BNE   SVOFF0              )OFF HOLD   TO   )OFF                49430000
         DROP  10                  WHICH WAS USED TO REACH SVOFF0       49440000
*        TRANSMUTED )OFF ENTERS )OFF HOLD HERE                          49450000
SVOFFH1  BAL   LINK,OFFSUB         LOSE WORKSPACE ETC.                  49460000
         CLI   PTTYPE,Q103A                                             49470000
         BH    SVTYI1              NO TIMEOUT FOR NON-DIALUP            49480000
         TM    IOB2,Q4WMDM                                              49490000
         BO    SVTYI1              NO TIMEOUT FOR MODEMS.               49500000
*                                                                       49510000
*        SVOFFH IS TIMING DEPENDENT.                                    49520000
*        WE ASSUME THAT TERMINAL IS STILL IN WRITES TYPING THE          49530000
*        SIGN OFF STATISTICS.  SETIDLE WITH INWAIT WILL UNLOCK KEYBD    49540000
*                                                                       49550000
         LM    2,3,SVOFLIM                                              49560000
         OR    2,PTR                                                    49570000
         BAL   5,ENQIE                                                  49580000
         B     SVTYI1              INITMOP SUBROUTINE                   49590000
*        MAKES TIMING NON-CRITICAL.                                     49600000
*                                                                       49610000
*        SUBROUTINE TO PURGE TERMINAL FROM SYSTEM AND CONDITION MPXINT  49620000
*        TO LOOK FOR SIGN ON MESSAGE                                    49630000
OFFSUB   MVI   ACTIVE,INWAITM+NONINM+MISCM                              49640000
         PTSET ACTIVE                                                   49650000
         MVI   IOB1,NSIGNM         NOT SIGNED ON                        49660000
         PTSET IOB1                                                     49670000
         NI    IOB2,Q4WMDM+LOEXP                                        49680000
         PTSET IOB2                                                     49690000
         LR    4,PTR                                                    49700000
         CL    PTR,OPTERM                                               49710000
         BNE   WSLOSEC                                                  49720000
*        THIS IS THE OPERATOR SIGNING OFF                               49730000
         MVI   OPNUM,X'FF'         TO REJECT MESSAGES TO OPERATOR       49740000
         MVC   OPTERM+1(3),=AL3(DUMINACT)                               49750000
*              QZA0 IS ONLY USER OF THIS VALUE OF OPTERM.  ALL OTHERS   49760000
*              ARE STOPPED BY OPNUM=X'FF'.                              49770000
         CLI   SHUTDOWN,0          SEE IF SHUTDOWN IS IN PROGRESS.      49780000
         BE    WSLOSEC             BRANCH IF NOT.                       49790000
*        OPERATOR HAS SIGNED OFF WITH SHUTDOWN IN PROGRESS.             49800000
*        - ENQUEUE A TIMER EVENT TO RETURN TO THE HOST, ALLOWING        49810000
*        TIME TO PRINT THE SIGN OFF ACCOUNTING.                         49820000
*                                                                       49830000
*        CODE COULD BE PLACED HERE TO ATTEMPT TO BOUNCE ANY REMAINING   49840000
*        USERS.                                                         49850000
*                                                                       49860000
         LM    2,3,DOWNLIM         INTERVAL EVENT.                      49870000
         CLI   PTTYPE,Q1050        1050 REQUIRES EXTRA TIME             49880000
         BNE   *+8                                                      49890000
         LA    3,6*300(0,3)        WAIT AN ADDITIONAL 6 SECONDS         49900000
         ST    LINK,MXTEM12                                             49910000
         BAL   5,ENQIE             ENQUEUED.                            49920000
         L     LINK,MXTEM12                                             49930000
         LR    4,PTR                                                    49940000
         B     WSLOSEC               DISPOSE OF WORKSPACE               49950000
*                                                                       49960000
*                                                                       49970000
*        SUSPEND AND SET DELAY SUBROUTINE                               49980000
*        R5 = RETURN                                                    49990000
*        R3 = TIME INTERVAL                                             50000000
TERMDEL  L     2,KIETCLOK          CLOKWAIT CODE FOR EXTIM4             50010000
         OR    2,PTR                                                    50020000
         TM    ACTIVE,ATTENM       ATTENTION ALREADY SET                50030000
         BCR   1,5                 BREAKS US OUT IMMEDIATELY            50040000
         LA    3,0(3)              AVOID TIME WARP. (15.5 HR MAX DEL    50050000
         OI    MISCB,CLOKWAIT                                           50060000
         OI    ACTIVE,MISCM                                             50070000
         B     ENQIE                                                    50080000
*                                                                       50090000
*        SUBROUTINE TO TERMINATE COPY OPERATION                         50100000
*        PTR IS ASSUMED TO BE SINK TERMINAL                             50110000
COPKILL  C     PTR,COPSINK         TEST FOR SINK                        50120000
         BCR   7,LINK              NO, IGNORE                           50130000
         L     PTR,COPSOUR         SOURCE PERTERM ADDRESS               50140000
         LA    BA,PTFBUF           DISCARD ANY REMAINING BUFFERS        50150000
         LR    1,LINK                                                   50160000
         BAL   LINK,FREEBQ                                              50170000
         LR    LINK,1                                                   50180000
         LM    0,1,PTABTM          ADD IN SOURCE TIME                   50190000
         MVC   PTABTM(8),ZERO      SOURCE                               50200000
         LR    4,PTR               FOR WSLOSE                           50210000
         L     PTR,COPSINK         RESTORE PTR                          50220000
         MVI   COPSINK+1,EMPTYM    MARK AS NO COPY                      50230000
         AR    0,1                 COMPUTE TIME USED BY SOURCE          50240000
         A     0,PTABTM                                                 50250000
         ST    0,PTABTM            INCLUDE SOURCE COMPUTE TIME          50260000
         NI    IOB1,255-COPYRM                                          50270000
*        DESUSPEND PERTERMS IN SDWAIT TO MAKE FURTHER COPIES FEASIBLE.  50280000
         LM    0,2,PTBXLE                                               50290000
COPDS1   NI    MISCB-PERTERM(2),255-SDWAIT  DESUSPEND.                  50300000
         BNZ   COPDS2              ACTIVE.(MISCM). IS OR / MISCB        50310000
         NI ACTIVE-PERTERM(2),255-MISCM  MISCB IS ZERO.                 50320000
COPDS2   BXLE  2,0,COPDS1                                               50330000
         DROP  PTR                                                      50340000
         USING PERTERM,4                                                50350000
WSLOSEC  SSM   ALLOFF                LOSE WS IF IT EXISTS               50360000
         TM    MISCB,NOWSM         DRP6 OR CCCZ MAY HAVE DESTROYED      50370000
         MVI   MISCB,NOWSM           KILL WANTON BIT                    50380000
         PTSET MISCB                                                    50390000
         BCR   7,LINK               SOURCE WORKSPACE ALREADY            50400000
         MVI   CDTERM,0            CHECK TO SEE IF SOURCE WS            50410000
         C     4,CDTERM            IS INVOLVED IN A DISK OPERATION      50420000
         BNE   WSLOSE              NO, KILL IT NOW                      50430000
         CLI   SELBUSY,0           CDTERM IS MEANINGLESS IF CHANNEL IS  50440000
         BE    WSLOSE              IDLE                                 50450000
         MVI   CDOP,16+0*(SELWSK-*)  BRANCH TO SELWSK FROM SELNOR       50460000
         BR    LINK                WS WILL BE LOST THEN                 50470000
*                                                                       50480000
*        A COPY SOURCE MAY NOT HAVE A WS ASSIGNED IF A LEMP             50490000
*        WAS ENQUED.                                                    50500000
*                                                                       50510000
*                                                                       50520000
*        ELIMINATE WORKSPACE DESIGNATED BY R4                           50530000
WSLOSE   SSM   ALLOFF              SELRDZ COULD CAUSE TROUBLE           50540000
         CLI   PTCORE+1,EMPTYM                                          50550000
         BE    COPK2               NOT IN CORE                          50560000
         L     1,PTCORE                                                 50570000
         MVI   PCTERM+1-PERCORE(1),EMPTYM                               50580000
         MVI   PTCORE+1,EMPTYM     THUS FREEING CORE SLOT               50590000
         BR    LINK                                                     50600000
         USING PERDISK,3           SEARCH DISK FOR SOURCE WORKSPACE     50610000
COPK2    ST    4,MXTEM12                                                50620000
         LM    0,3,PDBXLE                                               50630000
COPK3    CLC   PDTERM+1(3),MXTEM12+1                                    50640000
         BE    COPK4               FOUND IT                             50650000
         BXLE  3,0,COPK3                                                50660000
         UGH   ,                   WORKSPACE MUST BE ON DISK            50670000
COPK4    MVI   PDTERM+1,EMPTYM     LOSE WORKSPACE                       50680000
         BR    LINK                                                     50690000
         DROP  3,4                                                      50700000
         USING PERTERM,PTR                                              50710000
*                                                                       50730000
*                                                                       50740000
*        CONVERT PTR TO TERMINAL NUMBER                                 50750000
CVTERM   SR    0,0                                                      50770000
         LR    1,PTR                                                    50780000
         S     1,PTBXLE+8                                               50790000
         D     0,PTBXLE           R1=TERMINAL NUMBER                    50800000
         BR    2                                                        50810000
*                                                                       50820000
*        RECMSUB CHECKS TO SEE IF MESSAGE CAN BE PLACED IN BUFFER.      50830000
*        RETURNS TO CALLER IF MESSAGE IS NOT PLACED IN BUFFER.          50840000
RECMSUB  L     10,=A(REMRECM)      LOAD BASE REG FOR WILD BLUE YONDER   50850000
         TM    IOB1,BROADM+RINGM   CHECK FOR SPURIOUS CALL              50860000
         BCR   7,10   BNZR    REMRECM                                   50870000
         BR    LINK                                                     50880000
*                                                                       50900000
VALTERM  L     1,REGSV+4           COMPUTE PERTERM BASE REGISTER        50910000
         CL    1,TERMMAX                                                50920000
         BCR   11,LINK  BNLR       TOO BIG                              50930000
         STC   1,MSGTEM            DESBYTE SETTING                      50940000
         MH    1,PTBXLE+2                                               50950000
         A     1,PTBXLE+8         POINTER TO ADDRESSEE                  50960000
         CLI   0(1),0              DUMMY PERTERM                   P035 50970000
         BCR   8,LINK   BER        YES                             P035 50980000
         B     4(LINK)                                                  50990000
*                                                                       51000000
*                                                                       51010000
*                                                                       51020000
*        RNEWBUF ATTACHS ANOTHER BUFFER TO READ CCW CHAIN.              51030000
*        NEW BUFFER ADDRESS  IS ALREADY IN BA                           51040000
         USING PERBUF,1            POINT TO FORMER LAST BUFFER          51050000
RNEWBUF  L     1,PTLBUF                                                 51060000
RNEWB1   MVI   PBFLAG,0                                                 51070000
         O     BA,TICCON           MAKE SURE BUFFER AD IS TIC           51080000
         ST    BA,PBTIC            CHAIN TO PREVIOUS OLD BUFFER         51090000
         ST    BA,PTLBUF           MARK AS NEW LAST BUFFER              51100000
         DROP  1                                                        51110000
*        RNEWB2 INITIALIZES A NEW BUFFER                                51120000
         USING PERBUF,BA                                                51130000
RNEWB2   LA    0,1                 UPDATE BUFFER COUNT                  51140000
         AH    0,PTBFA                                                  51150000
         STH   0,PTBFA                                                  51160000
RNEWB3   LA    0,PBSTAR            SETUP CCW ADDR AND COUNT             51170000
         ST    0,PBCCW                                                  51180000
         MVC   PBCCW+4(8),RNBCON                                        51190000
         DROP  BA                                                       51200000
         BR    LINK                                                     51210000
*                                                                       51220000
*        OUTPUT BUFFER RATIONING                                        51230000
*        FSHARE HAS BEEN SET BY POSOM AT LAST SIGN ON-OFF               51240000
*        FSHARE = TOTBC * OVERBOOK DIV PLUS / SIGNEDON                  51250000
*        TOTBC = COUNT OF BUFFERS CREATED BY SUPINI                     51260000
*        MAXRAT IS (FREEBC-+/SIGNEDON) MIN (20*PTBFA=0)+FSHARE-PTBFA    51270000
*        LINK = RETURN                                                  51280000
TYORAT   L     0,FSHARE                                                 51290000
         SH    0,PTBFA                                                  51300000
         BNP   SETBUFWQ            RATION ALREADY EXCEEDED              51310000
         C     0,FSHARE            FIRST OUTPUT LINE GETS EXTRA RATION  51320000
         BNE   *+8                 TO ALLOW BOOTLEG BACKSPACE ETC.      51330000
         AH    0,POSO2             ADD MAXIMUM VALUE OF FSHARE          51340000
         L     2,FREEBC                                                 51350000
         S     2,POSO              THIS IS TO PROTECT READ STATE PORTS  51360000
         BNP   SETBUFWQ            OUTPUT CAN WAIT, PCI CANNOT          51370000
         CR    0,2                                                      51380000
         BH    *+6                                                      51390000
         LR    2,0                                                      51400000
         ST    2,MAXRAT            MIN                             2222 51410000
         BR    LINK                                                     51420000
*                                                                       51430000
*        NOTE FROM UNDERGROUND EDIT AND INSERTION                       51450000
*        R3 POINTS TO HALFWORD COUNT AND ZSYMBOL TEXT                   51460000
*        NOTE THAT PTR IS DESTROYED                                     51470000
NUINS    ST    LINK,MXTEM12+8      RETURN                               51480000
         CLI   OPNUM,X'FF'         IGNORE NOTE WHEN OPERATOR            51490000
         BCR   8,LINK  BER         IS NOT SIGNED ON                     51500000
         MVI   MAXRAT,INFIN        NOTES FROM UNDERG IS GREEDY          51510000
         L     PTR,OPTERM          USE OPERATOR'S TERMINAL TYPE         51520000
         BAL   LINK,TYOSUB                                              51530000
         B     NUINSZ              NO BUFFERS, LOSE THIS NOTE           51540000
         OI    IOB1,BROADM         SIGNAL OPERATOR                      51550000
         LA    PTR,NUTERM          FAKE PERTERM, NOTES FROM UNDERGROUND 51560000
         BAL   LINK,TYOINS         CHAIN MULTIPLE NOTES TOGETHER        51570000
NUINSZ   L     LINK,MXTEM12+8                                           51580000
         BR    LINK                                                     51590000
*                                                                       51610000
*        TYOINS APPENDS A CHAIN OF BUFFERS TO OUTPUT BUFFER CHAIN OF A  51620000
*        PARTICULAR TERMINAL.  FOR A TERMINAL, CHAIN STARTS WITH PTFBUF 51630000
*        PTLBUF POINTS TO LAST BUFFER IN CHAIN.                         51640000
*        FBUF IS HEAD OF CHAIN TO APPEND                                51650000
*        BA POINTS TO TAIL                                              51660000
*        LINK = RETURN                                                  51670000
         USING PERBUF,BA                                                51680000
TYOINS   MVI   FBUF,TIC                                                 51690000
         MVI   PBFLAG,LINEZ+LISTZ                                       51700000
         LH    0,BUFTS             UPDATE BUFFER COUNT                  51710000
         AH    0,PTBFA                                                  51720000
         STH   0,PTBFA                                                  51730000
         LR    0,BA                INTERCHANGE BA AND PTLBUF            51740000
         L     BA,PTLBUF           POINT TO END OF EXISTING CHAIN       51750000
         ST    0,PTLBUF                                                 51760000
         CLI   PTFBUF+1,EMPTYM                                          51770000
         BE    TYOINSE             EXISTING CHAIN IS EMPTY              51780000
         MVI   PBFLAG,LINEZ        OLD LAST IS END OF LINE, NOT LIST    51790000
         MVC   PBTIC,FBUF                                               51800000
         BR    LINK                                                     51810000
TYOINSE  MVC   PTFBUF,FBUF         OLD CHAIN WAS EMPTY                  51820000
         BR    LINK                                                     51830000
*                                                                       51840000
*        GETBUF OBTAINS ONE TYPEWRITER BUFFER                           51850000
*        EXIT IS 0(LINK) IF NO BUFFER                                   51860000
*        EXIT IS 4(LINK) WITH BUFFER ADDRESS IN R7                      51870000
GETBUF   CLI   FREEBA+1,EMPTYM                                          51880000
         BCR   8,LINK              NO BUFFERS LEFT                      51890000
         L     BA,FREEBC                                                51900000
         BCTR  BA,0                DECREMENT FREE BUFFER COUNT          51910000
         ST    BA,FREEBC                                                51920000
         L     BA,FREEBA                                                51930000
         TM    PBFLAG,FREEBIT                                           51940000
         UGH   Z                   NASTY, NOT A FREE BUFFER             51950000
         MVI   PBFLAG,0                                                 51960000
         MVC   FREEBA+1(3),PBTIC+1 UPDATE FREE BUFF LIST                51970000
         B     4(LINK)                                                  51980000
         DROP  BA                                                       51990000
*                                                                       52000000
*        FREEBQ IS CONDITIONAL BUFFER RELEASE.                          52010000
*        BA POINTS TO HEAD-OF-CHAIN WORD IN SOTRAGE                     52020000
FREEBQ   CLI   1(BA),EMPTYM                                             52030000
         BCR   8,LINK              NOTHING TO RELEASE                   52040000
         L     0,0(BA)             POINT TO FIRST BUFFER                52050000
         MVI   1(BA),EMPTYM        MARK EMPTY                           52060000
         LR    BA,0                POINT TO FIRST BUFFER                52070000
*        FREEBUF RETURNS A BUFFER CHAIN TO THE AVAILABLE (FREE) CHAIN   52080000
*        BA IS HEAD OF CHAIN TO BE RELEASED                             52090000
*        LINK = RETURN                                                  52100000
         USING PERBUF,BA                                                52110000
FREEBUF  SR    0,0                 TO COUNT RELEASED BUFFERS            52120000
         MVC   FBTEM,FREEBA        SAVE OLD FREE HEAD                   52130000
         ST    BA,FREEBA           NEW HEAD OF FREE LIST                52140000
         B     *+8                                                      52150000
FREEB1   L     BA,PBTIC            SEARCH FOR END OF LIST               52160000
         TM    PBFLAG,FREEBIT      VALIDITY CHECK OF FREE SPACE LIST    52170000
         UGH   O                   DOUBLE FREEING OF BUFF A NO NO       52180000
         OI    PBFLAG,FREEBIT      MARK AS FREE                         52190000
         AH    0,KHONE             UPDATE COUNT                         52200000
         TM    PBFLAG,LISTZ                                             52210000
         BZ    FREEB1                                                   52220000
         MVC   PBTIC,FBTEM         APPEND OLD FREELIST                  52230000
         DROP  BA                                                       52240000
*        R0 IS COUNT OF BUFFERS RELEASED                                52250000
         LH    BA,PTBFA            UPDATE COUNT FOR TERMINAL            52260000
         SR    BA,0                                                     52270000
         STH   BA,PTBFA                                                 52280000
         A     0,FREEBC            UPDATE GLOBAL COUNT                  52290000
         ST    0,FREEBC            UPDATE FREE BUFFER COUNT             52300000
*        REMOVE ONE TERMINAL FROM BUFFWAIT QUEUE                        52310000
         CLI   BUFWLTOP,EMPTYM                                          52320000
         BCR   8,LINK              QUEUE IS EMPTY                       52330000
         L     BA,BUFWLTOP-1       POINT TO A PERTERM                   52340000
         MVC   BUFWLTOP(BFWLMX+4-BUFWLTOP),BUFWLTOP+3  SHRINK QUEUE     52350000
         L     0,BUFWLEND          DECREASE END ADDRESS                 52360000
         SH    0,=H'3'                                                  52370000
         ST    0,BUFWLEND                                               52380000
         NI    MISCB-PERTERM(BA),255-BUFFWAIT                           52390000
         BCR   7,LINK                                                   52400000
         NI    ACTIVE-PERTERM(BA),255-MISCM                             52410000
         OI    RESCH,1             DISPATCH APL.                   3064 52420000
         BR    LINK                                                     52430000
*                                                                       52440000
*                                                                       52450000
*                                                                       52460000
*                                                                       53620000
*                                                                       53630000
*        GLITCH TO SUSPEND TERM ZERO FOR ATTENTION OR MESSAGE           53640000
*                                                                       53650000
*        TURN OFF ATTENTION BIT (STORE PROTECT INHIBITS INTRP)          53660000
SVATOFF  NI    ACTIVE,255-ATTENM                                        53670000
         MVC   PTCPULIM(2),PTCPULM2 RESET POSSIBLE SHORT TIME LIMIT     53680000
*                                  PRECEDING A FORCED ATTENTION         53690000
*        THIS IS REQUIRED IN CASE SOME USER GETS BOUNCY ON ATTN KEY.    53700000
         B     SVEXIT                                                   53710000
*                                                                       53720000
         SVRAPEIT                                                       53730000
*                                                                       53740000
         SVEXIT                                                         53750000
*                                                                       53760000
SVRPCON  DC    AL2(SVRAPE2-APLLOW)                                      53780000
SVRPTAB  DC    FL1'2,4,4,6'        INDEXED BY OPCODE BITS 0,1           53800000
*                                                                       53810000
*        PARAMTER BLOCKS FOR HISTCOMP USE AS PERHIST DSECT              53820000
*        INPUT KEYING SPEED                                             53830000
KEY      PHGEN 36300,122,3                                              53840000
*        SPECIAL DISK OPERATIONS POPULARITY                             53850000
SD       PHGEN 26,14,0             SCALE IS 2 (SEE XX SYMBOLS)          53860000
FBC      PHGEN 100,51,11           SEE STYONO                           53870000
BFA      PHGEN 20,21,12            SEE STYONO                           53880000
         PRINT GEN                                                      53890000
*                                                                       53900000
*        CCW CHAIN TO DETECT END OF TALK-DATA SEQUENCE ON 2741          53910000
*        AND WAIT FOR KEYBOARD TO LOCK AFTER POWERON RESET IN 2741      53920000
LIRS2741 CCW   REINHIB,SKALIRS,CC+SLI+SKIP,L'SKALIRS                    53930000
         CCW   WR,KCRD,SLI,1       SEND A CRD TO GET 2741 TO RCV TEXT   53940000
PREPCCW  CCW   X'06',SKAPREP,SLI+SKIP,1                                 53950000
KHONE    EQU   PREPCCW+6           CONSTANT H'1'                        53960000
MSENCCW  CCW   SENSE,0,SLI,1                                            53970000
WR       EQU   1                   270X WRITE                           54020000
RETIME   EQU   2                   270X READ TIMEOUT                    54030000
REINHIB  EQU   X'0A'               270X READ INHIBIT                    54040000
*        CONSTANTS FOR USE BY MXRCC1 270X INPUT CHANNEL                 54050000
*        PROGRAM ASSEMBLER.  FOUR BYTES ARE..                           54060000
*        0     ADDR(PTCCW1)-A(INPOLL)                                   54070000
*        1     COMMAND BYTE OF PTCCW1                                   54080000
*        2     COUNT OF PTCCW1                                          54090000
*        3     COMMAND BYTE OF PTCCW2                                   54100000
         DC    0F'0'                                                    54110000
KRC2741A DC    AL1(INPCRC-INPOLL,WR,1,REINHIB)  TO RESTORE KRC2741      54120000
KRC2741  DC    AL1(INPCRC-INPOLL,WR,1,REINHIB)                          54130000
KRC1050  DC    AL1(0,WR,5,REINHIB)                                      54140000
KRCAMW   DC    AL1(INPCRC+1-INPOLL,WR,2,RETIME)                         54150000
KRCAME   DC    AL1(0,ENABLE,1,RETIME)                                   54160000
         DS    0F                                                       54170000
RNBCON   DC    AL1(DC+PCI,LISTZ,0,TBL-1-(PBSTAR-PERBUF),TIC)            54180000
         DC    AL3(DISCARD)        ALSO USED AS CONSTANT  TIC DISCARD   54190000
TICCON   DC    AL1(TIC,0,0,0)                                           54200000
CREP     EQU   250*F*F             MPXPC ON SKIP FAIL                   54210000
*  END  MULTI-FUNCTION STORAGE * * * * * * * *                          54220000
*        1050, 2741 LINE CONTROL CHARACTERS                             54230000
CRB      EQU   X'3D'               END OF BLOCK, EOB, CIRCLE B          54240000
CRN      EQU   X'40'               1050 NEGATIVE RESPONSE               54250000
CRD      EQU   X'16'      ALSO KNOWN AS..                               54260000
*        CIRCLE UPPER CASE D                                            54270000
*        CIRCLE LOWER CASE D                                            54280000
*        POSITIVE ANSWER                                                54290000
*        POSITIVE POLL RESPONSE                                         54300000
*        READER READY                                                   54310000
*        INQUIRY                                                        54320000
*        EOA                                                            54330000
*        END OF ADDRESS                                                 54340000
*        POUND SIGN CHARACTER                                           54350000
*           8 21                                                        54360000
*        BID CHARACTER             6/4/68 - 2740 MANUAL.                54370000
CRC      EQU   X'1F'               END OF TRANSMISSION,EOT,CIRCLE C     54380000
CRY      EQU   X'76'               POSITIVE ANSWER, POSITIVE RESPONSE   54390000
UCRET    EQU   X'DB'               UPPERCASE CARRIAGE RETURN            54400000
LF       EQU   X'BB'               BCD LINE FEED                        54410000
EMPTYM   EQU   X'80'     USED IN HIGH ORDER BYTE OF VARIOUS ADDRESS     54420000
*        FIELDS TO INDICATE UNDEFINED ALSO MARKS END OF TYPEWRITER BUFF 54430000
EMPT3    EQU   X'800000'           EMPTY MARK FOR AL3 SETTING           54440000
INFIN    EQU   X'7F'             POSITIVE INFINITY                      54450000
DOWNLIM  IEBRN APLCNCL,12*300      TWELVE SECONDS                       54470000
MSPCI1   DC    F'0'                UNRZ19 MISSED PCI COUNT              54480000
MSPCI2   DC    F'0'                NO BUFFER AVAILABLE AT MREADPCI      54490000
BROADPT  DC    A(BROADBF)          POINTS TO BROADCAST MESSAGE BUFFER   54500000
SOMPT    DC    A(SOMBF)            POINTS TO SIGN-ON MESSAGE BUFFER     54510000
CCBTR    DC    AL1(13,14,15,4,5,0,1)  TO RECONSTRUCT SAVCSW FROM CCB    54520000
*        FOLLOWING WORDS ARE USED BY TYOINS CALLS IN SELRTRY TO ENQ     54530000
*        NOTES FROM THE UNDERGROUND IN PSUEDO PERTERM FOR RECEPTION     54540000
*        BY OPTERM AT SVRECM3.                                          54550000
         CNOP  2,4                 ALIGN NUBFA                          54560000
NUBFA    DC    H'0'                NOTES FROM UNDERGROUND BUFFER COUNT  54570000
NUFBUF   DC    A(EMPT3)            POINTS TO FIRST NOTE FROM UNDERGROUN 54580000
NULBUF   DC    A(EMPT3)            POINTS TO LAST BUFFER OF NFU         54590000
NUTERM   EQU   NUBFA-(PTBFA-PERTERM)   DUMMY PERTERM BASE ADDRESS       54600000
MSGTEM   DS    3F                  SV OLD PSW, ADDRESSEE TERM NUMBER    54610000
MPXPCT   DC    H'9'                                                     54620000
         DC    AL1(ZM,ZP,ZX,ZP,ZC,ZBLANK)                               54630000
MPXCTA   DC    2X'00'              UNIT ADDRESS IN HEX                  54640000
         DC    AL1(ZCR,ZEOB)                                            54650000
HEXTAB   EQU   *-X'F0'                                                  54660000
         DC    AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZA,ZB,ZC,ZD,ZE,ZF)     54670000
SVOFLIM  DC    A(IETSOHK*F*F*F,OFFHLIM)                                 54760000
KIETCLOK DC    A(IETCLOK*F*F*F)                                         54770000
ADIAG1   DC    A(TIC*F*F*F+DIAG1)                                       54780000
INPCON   DC    AL3(INPOLL)         FOR MXRCCC                           54790000
MAXRAT   DC    F'10'               TEMP GLICH                      2222 54800000
BUFTS    DC    H'0'                BUFFER INCREMENT THIS SVC            54810000
FBUF     DC    A(EMPT3)            TYOSUB, TYOINS COMMUNICATION         54820000
FBTEM    DC    A(EMPT3)            FREEBUF TEMP                         54830000
*        BUFWLTOP IS A FIFO QUEUE OF TERMINALS IN BUFFWAIT.  EACH       54840000
*        ENTRY IS THREE BYTES LONG.  END OF LIST IS AN ENTRY WITH FIRST 54850000
*        BYTE=EMPTYM.  FULL WORD ATBUFWLTOP-1 IS OLDEST ENTRY.          54860000
*        BUFWLEND POINTS TO A BYTE CONTAINING EMPTYM.                   54870000
BUFWLEND DC    A(BUFWLTOP)         POINTER TO END OF QUEUE              54880000
BFLEMAX  DC    A(BFWLMX)             MAX VALUE OF BUFLEND               54890000
STBFW1   DC    A(0)                FOR INSERTION OF PERTERM ADDRESS     54900000
         DC    AL1(EMPTYM)         FOR INSERTION OF END MARK            54910000
BUFWLTOP DC    259AL1(EMPTYM)      BUFF WAIT QUEUE                      54930000
BFWLMX   EQU   *-7                                                      54980000
*                                                                       54990000
ERINC    DC    AL1(1,2,0)          MPX ERROR COUNTER                    55000000
LIRSINC  DC    AL1(1,2,3,4,5,6,7,8,9,0) LIRS RETRY COUNTER              55010000
*                                                                       55020000
*                                                                       55030000
*                                                                       55040000
         USING REMTYO,8                                                 55050000
ICR      EQU   0   TRUE COUNT OF CHARACTERS REMAINING IN INTERNAL BUFF  55060000
BCR      EQU   4   SS COUNT OF CHARACTERS REMAINING IN EXTERNAL BUFFER  55070000
DEST     EQU   3                   DESTINATION ADDRESS IN EXTERNAL BUFF 55080000
SR       EQU   5                   SOURCE ADDRESS IN INTERNAL BUFFER    55090000
BA       EQU   7                                                        55100000
REMTYO   LH    6,0(3)              SS COUNT OF INTERNAL CHARACTERS      55110000
         LTR   5,6                                                      55120000
         BNH   STYOBAD             NEGATIVE OR ZERO LENGTH, EVIL        55130000
         ST    LINK,MXTEM12+4        RETURN ADDR                        55140000
         AH    6,KHONE             TRUE COUNT OF INTERNAL CHARACTERS    55160000
         SR    4,4                                                      55180000
         SH    5,KMXWIS            FUDGE FACTOR                         55190000
         BP    *+6                 AVOID NEGATIVE IDLE COUNT            55200000
         SR    5,5                 MAKE IT ZERO                         55210000
         D     4,KRZID             2741 IDLE COMPUTATION                55220000
         ST    5,MXTEM12                                                55230000
         SR    4,4                 ESTIMATE BUFFER REQUIREMENTS, THIS   55240000
         AR    5,6                 TYOSUB CALL                          55250000
         A     5,=A(L'PBSTAR)      TAKE CEIL                            55260000
         D     4,=A(L'PBSTAR)                                           55270000
         C     5,MAXRAT            IF TOO HIGH, SKIP TRT MVC TR AND2222 55280000
         BH    TYS10               AND OTHER FUTILE INSTRUCTIONS        55290000
         LA    SR,2(3)                                                  55300000
         TM    IOB1,COPYWM         COPY NOT INCLUDED IN HISTOGRAM       55320000
         BO    TYS11                                                    55330000
         LR    HISTVAL,6           OUTPUT LINE LENGTH IN ZSYMBOLS       55340000
         LA    PHR,PERHOUTL                                             55350000
         BAL   LINK,HISTCOMP       HISTOGRAM * * * * * * * * *          55360000
TYS11    LR    ICR,6                                                    55380000
         BAL   1,DEVXCC            COMPUTE PERDEVX ADDRESS              55390000
         USING PERDEVX,6           TO GET TYOTAD                        55400000
         L     6,TYOTAD                                                 55410000
         USING TYOTAA,6            DEVICE DEPENDENT TRANSLATE TABLE     55420000
         SR    1,1                 MARK AS TRT NEEDED                   55430000
         TM    IOB1,COPYWM                                              55440000
         BZ    TYS14               ORDINARY TYO                         55450000
         MVI   TYOTR,X'D5'         CHANGE TRANSLATE TO CLC              55460000
         LA    1,2000(SR)          MARK AS NO OVERSTRIKES               55470000
*        COPY TYO WILL ACT LIKE ORDINARY TYO WITH EXCEPTION OF SKIPPING 55480000
*        ALL TRANSLATE OPERATIONS                                       55490000
*        GET FIRST BUFFER                                               55500000
         USING PERBUF,BA                                                55510000
TYS14    BAL   LINK,GETBUF                                              55520000
         B     TYS10               NO BUFFERS (SHOULDN'T HAPPEN)        55530000
         MVC   BUFTS,KHONE         ONE BUFFER OBTAINED                  55540000
         ST    BA,FBUF             FIRST BUFFER ADDRESS                 55550000
         MVI   BINC,PBSTAR-PERBUF  ASSUME NO TERM CONTROL CHARS AT FRON 55560000
         CLI   PTTYPE,Q1050                                             55570000
         BL    TYS16               2741 NEEDS IDLES.               3587 55590000
         BH    TYS0                IDLE AND CRD NOT NEEDED              55600000
         MVI   RESID,CRD           END OF ADDRESS FOR 1050              55640000
         MVI   BINC,PBSTAR+1-PERBUF  PROTECT INSERTED CRD               55650000
TYS0     MVI   MXTEM12+3,0         NO IDLE CHARACTERS                   55670000
         B     TYS1                DON'T NEED IDLES.               3587 55710000
* IDLES ARE ADDED TO FRONT OF TEXT TO PREVENT SUPEREDIT OVERPRINT. 3587 55720000
TYS16    L     4,CURRENTM          ADDRESS OF WORKSPACE.           3587 55730000
         LA    4,0(4)                                              3587 55740000
         CL    4,=A(SCHSAVE)       REALLY A WORKSPACE?             3587 55750000
         BE    TYS1                NO.                             3587 55760000
         LH    3,CARRPOS-M(4)      LOCATION OF CARRIER             3587 55770000
         SR    2,2                                                 3587 55780000
         STH   2,CARRPOS-M(4)      CLEAR CARRIER POINTER.          3587 55790000
         LTR   3,3                 IF CARRIER IS AT LEFT MARGIN,   3587 55800000
         BZ    TYS1                NO IDLES ARE NEEDED.            3587 55810000
         LA    3,20(3)             ADD A MIN OF 2 IDLES.           3587 55820000
         D     2,KRZID             COMPUTE IDLE COUNT.             3587 55830000
         LA    2,15                MAX IDLE COUNT.                 3587 55840000
         CR    2,3                 IF IDLE COUNT                   3587 55850000
         BNL   TYS17               EXCEEDS MAX OF 15,              3587 55860000
         LR    3,2                 SET TO 15.                      3587 55870000
TYS17    STC   3,IDLMVC+1          SETUP MVC FOR IDLE COUNT.$$$$$  3587 55880000
         LR    4,3                                                 3587 55890000
         AH    3,BINC-1            UPDATE BINC TO INCLUDE          3587 55900000
         STC   3,BINC              ADDITION OF IDLES.              3587 55910000
         LA    DEST,PBSTAR         DATA AREA FOR WRITE.            3587 55920000
* $$$ IDLMVC MODIFIED BY TYS17                              $$$$$  3587 55930000
IDLMVC   MVC   0(1,DEST),DCZEOB    MOVE IDLES TO BUFFER.           3587 55940000
         EX    4,TYOTR             TRANSLATE IDLES                 3587 55950000
         MVC   RESID(2),0(DEST)    MAKE SURE RESID IS XLATED       3587 55960000
*        INITIALIZE A NEW BUFFER                                        55970000
TYS1     LA    DEST,PBSTAR         DATA ADDRESS FOR WRITE               55980000
         ST    DEST,PBCCW          OR DC CCW                            55990000
         LA    BCR,TBLM1                                                56000000
         SH    BCR,BINC-1                                               56010000
         LA    DEST,PBSTAR-PERBUF(BA,0)  MODIFIED AT TYS5&TYS6 $$$$$$$$ 56020000
BINC     EQU   *-1                 VALUES ARE PBSTAR+IOTA 3             56030000
         MVI   BINC,PBSTAR-PERBUF    SET TO NORMAL VALUE                56040000
         MVC   PBSTAR(2),RESID     RESIDUE FROM LAST OVERSTRIKE         56050000
*        DEST & BCR ARE SETUP, ANY RESIDUAL CHARACTERS FROM             56060000
*        BUFFER OVERFLOW DURING BACKSPACE INSERTION ARE NOW AT START    56070000
*        OF THIS NEW BUFFER                                             56080000
         LTR   1,1                 TRT LEAVES R1 NON-ZERO               56090000
         BNZ   TYS2                SKIP THE TRT                         56100000
*        TYS3 ASSUMES LAST BYTE OF BUFFER IS NOT LAST BYTE OF STORE     56110000
TYS3     LR    1,ICR               LOOK FOR NEXT OVERSTRIKE             56130000
         EX    1,TYOTRT                                                 56140000
         BC    10,*+12                                                  56150000
         STC   2,RESID+1           SAVE SECOND GRAPHIC                  56260000
         B     TYS2                                                     56270000
         LA    1,20(1,SR)          INDICATE NO MORE OVERSTRIKES         56280000
TYS2     EX    BCR,TYOMVC          MOVE TO BUFFER                       56290000
         EX    BCR,TYOTR                                                56300000
         LA    SR,1(SR,BCR)                                             56310000
         CR    1,SR                R1 WAS SET BY TRT                    56320000
         BL    TYS13               DO BACKSPACE INSERTION               56330000
TYS15    BCTR  ICR,0               ICR IS TRUE COUNT, BCR IS SS COUNT   56340000
         SR    ICR,BCR                                                  56350000
         BP    TYS8                                                     56360000
*        INTERNAL BUFFER IS NOW DEPLETED, TRY IDLE CHAR INSERTION       56370000
         BALR  2,0                 PRESERVE CONDITION CODE              56380000
         AR    BCR,ICR             BCR IS (-1)+ ICR OF TYS2             56390000
         LA    DEST,1(DEST,BCR)    UPDATE DESTINATION IN EXT BUFFER     56400000
         CLI   MXTEM12+3,0         SEE IF IDLE CHARACTERS REQUIRED      56410000
         BE    TYS4                NO, MOP UP FINAL BUFFER              56420000
         LCR   BCR,ICR                                                  56430000
         BCTR  BCR,0               BCR IS NOW CORRECT                   56440000
         L     ICR,MXTEM12         COUNT OF IDLE CHARACTERS             56450000
         MVI   MXTEM12+3,0         PREVENT LOOPING                      56460000
         LA    SR,DCZEOB           SOURCE OF 2741 PROTO-IDLES           56560000
         LA    1,797(SR)           INDICATE NO OVERSTRIKES              56580000
         SPM   2                   RESTORE CONDITION CODE               56590000
         BZ    TYS8                GET ANOTHER BUFFER                   56600000
         B     TYS2                PUT IDLES IN CURRENT BUFFER          56610000
*        FINISHUP LAST BUFFER                                           56620000
TYS4     LA    BCR,PBSTAR                                               56630000
         SR    DEST,BCR                                                 56640000
         STH   DEST,PBCCW+6        COUNT FOR FINAL CCW                  56650000
         MVI   PBTIC+1,EMPTYM      END OF CHAIN                         56660000
         MVI   PBCCW+4,SLI                                              56670000
         MVI   PBFLAG,LINEZ+LISTZ                                       56680000
*        EXIT WITH BA POINTING TO LAST BUFFER OF LINE                   56690000
*        ... FBUF POINTING TO FIRST BUFFER OF LINE                      56700000
         MVI   TYOTR,X'DC'         RESTORE TO TRANSLATE                 56710000
         L     LINK,MXTEM12+4                                           56720000
         B     4(LINK)             TAKE SUCCESS EXIT                    56730000
*        BACKSPACE INSERTION MECHANISM                                  56740000
TYS13    LA    2,2(BCR,1)          REVISE COUNT OF CHARACTERS MOVED     56750000
         SR    2,SR                K IS R1+BCR+2-SR                     56760000
         LA    SR,1(1)             NEW SOURCE REGISTER                  56770000
         SR    ICR,2               INTERNAL CHARACTERS REMAINING        56780000
         BNP   STYOBAD             MESSAGE ENDS WITH OVERSTRIKE         56800000
         AR    DEST,2              UPDATE DESTINATION IN BUFFER         56840000
         SR    BCR,2               BUFFER CHAR REMAINING, UPDATE        56850000
         BM    TYS5                NO ROOM FOR BACKSPACE                56860000
         MVC   0(1,DEST),ZBSUC+TYOTAA                                   56870000
         BZ    TYS6                NO ROOM FOR SECOND GRAPHIC           56880000
         MVC   1(1,DEST),RESID+1    INSERT SECOND GRAPHIC               56890000
         AH    BCR,=H'-2'     TEST FOR END OF BUFFER               C022 56900000
         BM    TYS7                NO MORE ROOM                         56910000
         LA    DEST,2(DEST)        UPDATE DESTINATION                   56920000
         B     TYS3                INSERT AT LEAST ONE MORE             56930000
TYS6     MVI   BINC,PBSTAR+1-PERBUF                                     56940000
         MVC   RESID(1),RESID+1    NEXT BUFFER STARTS WITH 2ND GRAPHIC  56950000
         B     TYS7                                                     56960000
TYS5     MVI   BINC,PBSTAR+2-PERBUF  NEXT BUFFER STARTS WITH            56970000
         MVC   RESID(1),ZBSUC+TYOTAA   BACKSPACE AND SEC3ND GRAPHIC     56980000
TYS7     SR    1,1                 DO NEXT TRT                          56990000
*        COMMON END OF BUFFER LOGIC                                     57000000
TYS8     EQU   *                                                        57010000
*        REGISTER USAGE HERE..  ICR, R1 AND SR STILL NEEDED             57020000
*              R2, DEST & BCR ARE FREE NOW                              57030000
         LR    BCR,BA              SAVE PREVIOUS BUFFER ADDRESS         57040000
         LH    DEST,BUFTS          BUFFERS OBTAINED IN THIS CALL        57050000
         C     DEST,MAXRAT         RATION FOR THIS CALL OF TYOSUB  2222 57060000
         BNL   TYS9                                                     57070000
         BAL   LINK,GETBUF         GET ANOTHER BUFFER                   57080000
         B     TYS9                NO BUFFER (SHOULD NOT HAPPPEN)       57090000
         LA    DEST,1(DEST)        INCREMENT COUNT OF BUFFERS OBTAINED  57100000
         STH   DEST,BUFTS                                               57110000
         ST    BA,PBTIC-PERBUF(BCR)  LINK NEW BUFFER INTO CHAIN         57120000
         MVC   PBCCW+4-PERBUF(5,BCR),TYSK1   DATACHAIN,0,L'PBSTAR,TIC   57130000
         B     TYS1                                                     57140000
*        NOT ENOUGH BUFFERS FOR THIS TYO                                57150000
*        BCR POINTS TO LAST BUFFER OBTAINED                             57160000
TYS9     MVI   PBFLAG-PERBUF(BCR),LISTZ                                 57170000
         AH    DEST,PTBFA          DEST = BUFTS                         57180000
         STH   DEST,PTBFA          FREEBUF WILL DECREMENT PTBFA SO COM- 57190000
*                                  PENSATE NOW.                         57200000
         L     BA,FBUF             RELEASE BUFFER CHAIN                 57210000
         BAL   LINK,FREEBUF                                             57220000
TYS10    MVI   TYOTR,X'DC'         RESTORE TRANSLATE                    57230000
         L     LINK,MXTEM12+4                                           57240000
         BR    LINK                TAKE FAILURE EXIT                    57250000
TYOTRT   TRT   0(1,SR),TYOTAT                                           57270000
TYOTR    TR    0(1,DEST),TYOTAA                                         57320000
TYOMVC   MVC   0(1,DEST),0(SR)                                          57330000
RESID    DC    XL2'0'              FOR OVERSTRIKES ON BUFFER BOUNDARY   57340000
TYSK1    DC    AL1(DC,0,0,L'PBSTAR,TIC)  FOR USE AT TYS8                57350000
         DROP  6,8,BA                                                   57360000
DCZEOB   DC    26AL1(ZEOB)         BECOMES BCD IDLE CHAR                57380000
*                                                                       57400000
         SPACE 3                                                        57410000
*        USE OF PERTERM POINTERS DURING INPUT                           57420000
*                                                                       57430000
*PTFBUF  POINTS TO LAST UNTRANSLATED BUFFER.  RTRBUF (CALLED ON PCI)    57440000
*        TRANSLATES ONE BUFFER AND EXITS WITH PTFBUF AND BA POINTING TO 57450000
*        THE BUFFER JUST TRANSLATED.  MXRCCC SET THE INITIAL VALUE OF   57460000
*        PTFBUF TO A(PTCCW2) AND PTCCW3 TO TIC TO FIRST BUFFER.         57470000
*PTLBUF  POINTS TO LAST BUFFER IN INPUT CHAIN.  RNEWBUF MAINTAINS       57480000
*        PTLBUF DURING INPUT.                                           57490000
*PTIBUF  POINTS TO FIRST BUFFER IN INPUT CHAIN.  IT IS USED BY TYPEIN   57500000
*        AND THE APLSUP ROUTINES WHICH RELEASE INPUT BUFFERS.           57510000
*PTRBUF  NOT USED DURING INPUT.                                         57520000
*PTBFA   IS NUMBER OF BUFFERS POINTED TO BY PTIBUF.                     57530000
*                                                                       57540000
*                                                                       57550000
*        NORMAL END OF READ FOR MULTIPLEX DEVICE                        57560000
         USING UNRZ,10                                                  57570000
UNRZ     CLI   PTTYPE,Q103A        SEE IF THIS IS A 270X DEVICE         57580000
         BH    UNRZ6               BRANCH IF NOT.                       57590000
         CLI   PTRESP,CRD          VALIDITY CHECK ON READ OPERATION     57600000
         BE    UNRZ6               BRANCH ON POSITIVE RESPONSE.         57610000
         CLI   PTTYPE,QAMBIG       SEE IF TYPE IS UNRESOLVED.           57620000
         BNE   UNRRT               NO, RETRY 1050 MYSTERY               57630000
*                                                                       57640000
*        END OF READ, AMBIGUOUS DEVICE.                                 57650000
*        CRD FROM 2741 MAY HAVE BEEN LOST DUE TO VARIOUS RACE           57660000
*        CONDITIONS RESULTING FROM CONTROL MODE TIMEOUTS ON 270X        57670000
*        CONTROL UNITS.  PTRESP MAY CONTAIN THE RIGHT PARENTHESIS.      57680000
*                                                                       57690000
         IC    2,PTRESP            RES2741 EXITS TO UNRRTA IF RITEPAREN 57700000
         BAL   LINK,RES2741        IS NOT FOUND                         57710000
*        TERMINAL TYPE IS RESOLVED, BUT SIGN-ON MESSAGE IS DISPLACED    57720000
*        IN BUFFERS.                                                    57730000
*        RATHER THAN TRYING TO SHIFT IT RIGHT ONE BYTE, PRINT 'RESEND'  57740000
*        AND LET USER RETYPE IT.                                        57750000
         B     UNRRT                                                    57760000
*        PCI WAS MISSED, INCREMENT COUNT                                57770000
UNRZ19   L     1,MSPCI1                                                 57790000
         LA    1,1(1)                                                   57800000
         ST    1,MSPCI1                                                 57810000
         B     UNRRT               PRINT RESEND MAYBE AND UNLOCK KEYB   57860000
         USING PERBUF,4                                                 57870000
UNRZ6    EQU   *                                                        57880000
         MVI   SAVCSW,TIC          MAKE STORED CAW A TIC                57890000
         L     0,SAVCSW            TO FINAL CCW FOR COMPARISON          57900000
         SH    0,=H'8'             PURPOSES                             57910000
         ST    0,LASTBUF           FOR FUTURE COMPARISONS               57920000
         C     0,RNBCON+4          COMPARE WITH TIC DISCARD             57930000
         BE    UNRZ19              WE MISSED A PCI                      57940000
         CLI   PTTYPE,QAMBIG                                            57950000
         BNL   UNRZ24              THIS IS END OF INPUT                 57960000
*        CHECK FOR 2741 LINE FEED                                       57970000
         L     4,PTFBUF            POINT TO LAST TRANSLATED BUFFER      57980000
         BALR  LINK,0              TRANSLATE ALL INPUT BUFFERS UNTIL    57990000
         C     0,PBTIC             WE HAVE ONE UNTRANSLATED BUFFER      58000000
         BNE   RTRBUF              WITH EXTRA ROOM                      58010000
         L     4,PBTIC             POINT TO UNTRANSLATED BUFFER         58020000
*        SOME CHARACTER OF THIS BUFFER OTHER THAN THE LAST IS A         58030000
*        CRC (UNLESS BUFFER IS EMPTY).  CHECK TO SEE IF CRC IS PRECEDED 58040000
*        BY A CARRIAGE RETURN.  EMPTY BUFFER CASE HANDLED BY UNRZ27     58050000
         LH    1,PBCCW+6           COMPUTE NUMBER OF CHARACTERS         58060000
         SH    1,SAVCSW+6          TRANSFERRED.   NOTE THAT IS NOT      58070000
*              EQUAL TO NUMBER OF DATA CHARS IN BUFFER                  58080000
         BZ    UNRZ27              EMPTY BUFFER CASE                    58090000
         LA    0,PBSTAR                                                 58100000
         MVI   PBCCW,0             DO 24 BIT ARITHMETIC                 58110000
         S     0,PBCCW                                                  58120000
         SR    1,0                 GIVING NUMBER OF CHARS IN BUFFER     58130000
         BCT   1,UNRZ26A           CRET AND CRC IN THE SAME BUFFER MAYB 58140000
*        CRC IS FIRST CHARACTER IN BUFFER                               58150000
*        POTENTIAL CRET IS IN THE PRECEDING BUFFER                      58160000
         L     2,PTFBUF            LOOK IN LAST TRANSLATED BUFFER       58170000
         TM    PBFLAG-PERBUF(2),FORCELF  THIS BIT IS SET IN PTCCW2 BY   58180000
*                                  MXRCCC AND IS RESET BY SVTYIX WHEN   58190000
*                                  A BUFFER ENDING WITH ZCR IS RELEASED 58200000
         BO    *+8                 SKIP CLI, CONDITION CODE IS 3        58210000
         CLI   PBLAST-1-PERBUF(2),ZCR                                   58220000
         L     2,PBCCW             R2 POINTS TO CRC                     58230000
         B     UNRZ26C             TEST CONDITION CODE                  58240000
UNRZ26B  CLI   =AL1(UCRET),X'80'   FORCE UPPER CASE COMPARE             58250000
UNRZ26A  IC    2,PBSTAR-1(1)       POTENTIAL CARR RETURN                58260000
         EX    2,UNRZ26B           COMPARE WITH UPPER&LOWER CASE CRET   58270000
         LA    2,PBSTAR(1)         POINT TO CRC                         58280000
UNRZ26C  BE    UNRZ25              THIS IS NOT 2741 LINE FEED           58290000
         MVI   0(2),LF             INSERT LINE FEED (BCD CODE)          58300000
         LA    2,1(2)                                                   58310000
         ST    2,PBCCW             RECOMPUTE CCW ADDR                   58320000
         MVC   PBCCW+6(2),SAVCSW+6 RESIDUAL COUNT TO NEW CCW            58330000
         C     4,PTLBUF                                                 58340000
         BNE   UNRZ30              WE HAVE AN EMPTY BUFFER              58350000
         BAL   LINK,GETBUF         TRY TO GET ANOTHER                   58360000
         B     UNRZ31              PRAY FOR PCI ON PARTIAL BUFFER       58370000
         BAL   LINK,RNEWBUF        LINK NEW BUFFER INTO CHAIN           58380000
UNRZ30   MVI   PBCCW+4,DC          TURN OFF PCI IN PARTIAL BUFFER       58390000
UNRZ31   ST    4,PTCCW3                                                 58400000
*        SETUP PTCCW1 TO TRANSMIT PSEUDO POLLING SEQUENCE FOR LINE FEED 58410000
         LA    1,Q2741LF                                                58420000
         CLI   PTTYPE,Q2741                                             58430000
         BE    UNRZ32              BRANCH IF REAL 2741                  58440000
         LA    1,QTS41LF           TSS IMITATION 2741                   58450000
UNRZ32   ST    1,PTCCW1            FORM WRITE CCW                       58460000
         MVI   PTCCW1,WR                                                58470000
         MVI   PTCCW1+7,L'Q2741LF                                       58480000
         MVI   PTCNT,0                                                  58490000
         B     MXSION                                                   58500000
*        UNRZ27 IS CASE OF..  CHANNEL END ON 2741 WITH NO UNTRANSLATED  58510000
*        CHARACTERS FOR THIS TERMINAL.  IF THIS IS REALLY LINEFEED,     58520000
*        RTRBUF HAS DONE AN EARLY 2741LF DETECTION FOR INLINE AND       58530000
*        UNRZ27 (WHICH ARE ASSUMED TO BE RACING EACH OTHER).            58540000
UNRZ27   L     4,PTFBUF                                                 58550000
         CLI   PBLAST-1,ZLF                                             58560000
         BNE   UNRZ25              BUFFER CONTAINS A ZCR                58570000
         L     4,PBTIC             POINT TO AN EMPTY BUFFER             58580000
         B     UNRZ31              SET PTCC3 TO TIC R4                  58590000
*        UNRZ24 AND UNRZ25 ARE NON 2741 AND NON LINE FEED CASES OF      58600000
*        CHANNEL END RESPECTIVELY.  ALL UNTRANSLATED BUFFERS ARE        58610000
*        PROCESSED, EMPTY INPUT BUFFERS ARE RELEASED.                   58620000
UNRZ24   BAL   LINK,RESTYPE        IN CASE TERM TYPE IS AMBIG           58630000
UNRZ25   L     4,LASTBUF                                                58640000
         LH    1,PBCCW+6           COMPUTE NUMBER OF                    58650000
         SH    1,SAVCSW+6          CHARS IN LAST TRANSFER               58660000
         ST    1,MXTEM12           FOR INPUT LENGTH HISTOGRAM           58670000
         BNZ   UNRZ25A                                                  58680000
*        LAST BUFFER IS EMPTY                                           58690000
         CL    4,PTIBUF            TEST FOR ALL BUFFERS EMPTY           58700000
         BE    UNRZ25C             YES, MANUFACTURE ZEOB IN 1ST BUFF    58710000
         MVI   MXTEM12+3,L'PBSTAR-1    CORRECT FOR BCTR HISTVAL,0 UNRZ  58720000
         L     4,PTFBUF            TRANSLATE ALL UNTR BUFFERS           58730000
         BALR  LINK,0              RETURN POINT FOR RTRBUF              58740000
         CLC   PBTIC,LASTBUF                                            58750000
         BNE   RTRBUF              LOOP UNTIL ALL ARE TRANSLATED        58760000
         MVI   PBLAST,ZEOB         MARK AS LAST BUFFER                  58770000
         B     UNRZ25B                                                  58860000
UNRZ25A  BAL   LINK,RTRBUF                                              58870000
         CL    4,LASTBUF                                                58880000
         BNE   UNRZ25A             TRANSLATE ANOTHER BUFFER             58890000
UNRZ25C  A     1,PBCCW                                                  58900000
         MVI   0(1),ZEOB           EXTRA EOB TO BE SURE                 58910000
UNRZ25B  MVI   PBFLAG,FILLBIT+LISTZ+LINEZ                               58970000
         MVI   PTFBUF+1,EMPTYM     NOT NEEDED NOW                       58980000
         CLC   PBTIC,RNBCON+4                                           58990000
         BE    UNRZ3               NO EMPTY BUFFERS IN CHAIN            59000000
         L     BA,PBTIC                                                 59010000
         BAL   LINK,FREEBUF        RELEASE EMPTY BUFFERS                59020000
UNRZ3    BAL   LINK,CORTIME                                             59030000
         TM    MISCB,NOWSM         SEE IF WORKSPACE IS ASSIGNED         59050000
         BO    UNRZ5              NO WORKSPACE                          59060000
         LR    2,0                                                      59070000
         LR    HISTVAL,0                                                59080000
         S     HISTVAL,PTMTIME     KEYING TIME THIS INPUT.              59090000
         ST    0,PTMTIME           TO MEASURE RESPONSE TIME.            59100000
         LR    0,HISTVAL                                                59110000
         A     0,PTMTIM3           CUMULATIVE KEYING TIME               59120000
         ST    0,PTMTIM3           SAVE FOR IBEAM RETRIEVAL.            59130000
         LA    PHR,PERHKEY                                              59140000
*        HISTOGRAM   ***  *  * *  * * ***  * * **  *  ** *              59150000
         BAL   LINK,HISTCOMP                                            59160000
*        HISTOGRAM ON INPUT ARRIVAL TIMES   **************************  59170000
         LA    PHR,PERHARIV        INPUT ARRIVAL TIMES HISTOGRAM        59180000
         LR    HISTVAL,2                                                59190000
         S     HISTVAL,PTMTIM2                                          59200000
         ST    2,PTMTIM2                                                59210000
         BAL   LINK,HISTCOMP                                            59220000
         XI    ACTIVE,INWAITM+NONINM                                    59230000
*        CHANGE USER STATE FROM AWAITING INPUT TO INPUT READY           59240000
         CLI   PTCORE+1,EMPTYM                                          59250000
         BE    UNRZ2               NOT IN CORE                          59260000
         L     1,PTCORE                                                 59270000
         MVC   PCQUONT-PERCORE(2,1),ZERO  URGE RETENTION IN CORE        59280000
         B     UNRZ4                                                    59290000
*        END OF READ WITH NO WORKSPACE ASSIGNED TO TERMINAL             59300000
UNRZ5    ST    0,PTMTIME           FOR HISTOGRAMS                       59310000
         ST    0,PTMTIM2           SAVE TIME OF FIRST EOB FOR HIST      59320000
         MVI   ACTIVE,MISCM        TURN OFF INWAIT TO PREVENT NEW SIO   59330000
         PTSET ACTIVE                                                   59340000
         BAL   LINK,LEMP           GET WORKSPACE LOADED                 59350000
         B     UNRZ4               CONTINUE READ MOP UP                 59360000
UNRZ2    MVI   FSWAP,1             TELL SCHED (AND/NONINM) IS NOW ZERO  59370000
*        NOTE THAT ALTHOUGH RSELSUB, SELRDZ COULD MAKE (AND/NONINM) ONE 59380000
*        (BY SELECTING THE USER NOW BEING PROCESSED), THE EXTRA SWAP    59390000
*        SHOULD TAKE PLACE ANYWAY.  THIS IS THE CASE WHERE THE HCSCNT   59400000
*        WINDOW IS ELONGATED.                                           59410000
         CLI   SELBUSY,0                                                59420000
         BNE   UNRZ4                                                    59430000
         BAL   LINK,RINGSUB  BECAUSE WORKSPACE IS ON DISK AND           59440000
*        DEVICE DEPENDENT MOPUP                                         59450000
UNRZ4    LH    HISTVAL,PTBFA       COMPUTE TOTAL NUMBER OF INPUT        59460000
         BCTR  HISTVAL,0           CORRECT FOR PARTIAL BUFFER           59470000
         MH    HISTVAL,RNBCON+2    CHARACTERS IN THIS LINE              59480000
         A     HISTVAL,MXTEM12                                          59490000
         LR    5,HISTVAL           SAVE FOR IDLE COMPUTATION            59500000
         TM    MISCB,NOWSM         SIGN-ON NOT INCLUDED IN HISTOGRAM    59510000
         BO    UNRZ41                                                   59520000
         LA    PHR,PERHRKEY                                             59530000
         BAL   LINK,HISTCOMP                                            59540000
UNRZ41   EQU   *                                                        59550000
         MVI   RESCH,1             FOR ENTRY TO GENERAL EXIT            59570000
         MVI   STATE,WRITES        MARK DEVICE END PRESENT.             59660000
         CLI   PTTYPE,Q1050+Q103A-Q103A  TEST FOR 1050                  59670000
         BH    SETIDLE             OTHER DEVICES DO NOT NEED ANSWER     59680000
         BE    UNRZ12              1050 DOES NOT NEED IDLE CHARACTERS   59690000
         LA    0,WCRDI             ADDR OF CCW                          59700000
         ST    0,PUCCB             FOR ERROR RETRY                      59710000
*        WRITE TO TERMINAL..  CRD AND ZERO OR MORE IDLES                59720000
*        NUMBER OF IDLES IS BASED UPON ESTIMATED CARRIAGE RETURN TIME   59730000
         SR    4,4                                                      59740000
         SH    5,KRZIS             SUBTRACT FUDGE FACTOR                59750000
         BNP   UNRZ11              NEGATIVE OR ZERO                     59760000
         D     4,KRZID                                                  59770000
         STC   5,WCRDI+7           IDLE CHAR COUNT                      59780000
         CLI   WCRDI+7,0           ZERO COUNT IS EVIL                   59790000
         BNE   *+8                                                      59800000
UNRZ11   MVI   WCRDI+7,1           FORCE MINIMUM                        59810000
         CLI   WCRDI+7,IDLMAX                                           59820000
         BL    MXSIO               WITHIN RANGE                         59830000
         MVI   WCRDI+7,IDLMAX      FORCE MAXIMUM                        59840000
         B     MXSIO                                                    59850000
*        SEND CRD (=OK ANSWER) AND THEN BLACKSHIFT SEQUENCE FOR         59860000
*        1050 RIBBON COLOUR CONTROL                                     59870000
UNRZ12   MVC   PTCCW1(9),BLKCCW1                                        59880000
         MVI   PTCCW2+4,CC+SLI     READ RESPONSE                        59890000
         MVC   PTCCW3,TBLKCCW3     TIC TO BLKCCW3                       59900000
         B     MXSION                                                   59910000
*                                                                       59920000
RESTYPE  CLI   PTTYPE,QAMBIG       CHECK FOR AMBIGUITY IN DEVICE TYPE.  59930000
         BCR   7,LINK             OK                                    59940000
         L     4,PTIBUF            POINT TO FIRST BUFFER                59950000
         IC    2,PBSTAR            FIRST DATA CHAR FOR RES2741 USE      59960000
*        RESOLVE 1050 VS 2741 ON BASIS OF POLLING SEQUENCE WHICH WORKED 59970000
         DC    0AL4(MXR2741)    INVESTIGATE BEFORE CHANGING * * * * * * 59980000
         CLI   PTRESP,CRD          SEE IF A SEQ REALLY WORKED.          59990000
         BNE   RES2741             NO - MAY BE LOST 2741 RACE.          60000000
         CLI   PTCCW1+7,1         2741 POLLING SEQ IS ONE CHARACTER     60010000
         BE    RES2741             2741 TSS OR STANDARD                 60020000
         MVI   PTTYPE,Q1050                                             60030000
         LA    PXR,Q1050-QAMBIG(PXR)                                    60040000
         BR    LINK                                                     60050000
RES2741  LA    3,Q2741                                                  60060000
         BAL   6,TRYRPAR                                                60070000
         LA    3,QTS41             MAYBE IT IS TSS 2741                 60080000
         BAL   6,TRYRPAR                                                60090000
*  TYPE IS NOT RESOLVABLE, UNLOCK KEYBOARD                              60100000
         B     UNRRTA              RETRY READ AS 2741                   60110000
*                                                                       60120000
TRYRPAR  L     PXR,PERDEVB         CHECK 2741 CHARACTER SET             60130000
         AR    PXR,3                                                    60140000
         L     1,TYOTAD-PERDEVX(PXR)                                    60150000
         EX    2,TRYCLI            LOOK FOR RIGHT PAREN                 60160000
         BCR   7,6                 NO MATCH                             60170000
         STC   3,PTTYPE                                                 60180000
         BR    LINK                                                     60190000
TRYCLI   CLI   ZRPAR(1),0          EXECUTED BY TRYRPAR                  60200000
         DROP  10                                                       60210000
         DROP  4                   PERBUF                               60220000
*                                                                       60230000
*        SETUP CCW AND FLAGS TO DISCONNECT HARD WIRE OR DIALUP LINE     60240000
         USING MXDCCC,10                                                60250000
MXDCCC   MVI   STATE,WRITES                                             60260000
         MVI   PTCCW1,ENABLE       DISABLE MUST BE AVOIDED FOR          60270000
         TM    IOB2,Q4WMDM         HARD WIRED LINES                     60280000
         BO    MXDCC1              SKIP DISABLE                         60290000
         MVI   PTTYPE,QAMBIG       MARK TERMINAL TYPE UNKNOWN           60300000
         MVI   PTCCW1,DISABLE      DISCONNECT DIALUP LINE               60310000
MXDCC1   LA    BA,PTIBUF           RELEASE ANY INPUT BUFFERS            60320000
         BAL   LINK,FREEBQ                                              60330000
         BAL   LINK,SAT8           RELEASE OUTPUT BUFFERS               60340000
         BAL   LINK,KSOHK          KILL SIGN OFF HOLD KILL EVENT        60350000
         MVI   PTCNT,0                                                  60360000
         MVI   ACTIVE,INWAITM+NONINM+MISCM                              60380000
         PTSET ACTIVE                                                   60390000
* DISABLE MUST BE AVOIDED FOR HARD WIRE LINES. RESULTS IN TIMEOUT. P056 60410000
         TM    IOB2,Q4WMDM         HDWIRE?                         P056 60420000
         BZ    MXDCC2              NO - ISSUE THE DISABLE.         P056 60430000
         CLI   SHUTDOWN,0          SHUTDOWN?                       P056 60440000
         BE    MXDCC2              NO - ISSUE AN ENABLE TO HARDWIR P056 60450000
         MVI   PTTYPE,QAMBIG       USED BY  UNWZ                   P056 60460000
         B     UNWZ                NO I/O NEEDED                   P056 60470000
MXDCC2   EQU   *                                                   P056 60480000
         LA    0,PTCCW1            FOR SIO ROUTINES                     60490000
         ST    0,PUCCB                                                  60500000
         MVC   PTCCW2(1),PTSAD     REFRESH SAD FIELD                    60510000
         MVI   PTCCW2+4,SLI        END OF CHAIN                         60520000
         B     MXSION                                                   60530000
         DROP  10                                                       60540000
*                                                                       60550000
*        RELEASE INPUT BUFFERS OF PRECEDING TYI                         60560000
SVBREL   LA    BA,PTIBUF                                                60570000
         BAL   LINK,FREEBQ                                              60580000
         B     SVEXIT                                                   60590000
         SPACE 3                                                        60600000
*        USE OF PERTERM POINTERS DURING OUTPUT.                         60610000
*                                                                       60620000
*PTFBUF  POINTS TO A CHAIN OF BUFFERS AWAITING OUTPUT.                  60630000
*PTLBUF  POINTS TO LAST BUFFER IN PTFUBF CHAIN.  IT IS MAINTAINED BY    60640000
*        TYOINS AND IS NOT VALID WHEN PTFBUF IS EMPTY.                  60650000
*PTIBUF  POINTS TO INPUT BUFFERS FROM LAST INPUT OPERATION OR ELSE WHEN 60660000
*        TRAWAITM IS SET PTIBUF POINTS TO A CHAIN OF MESSAGE BUFFERS    60670000
*        DESTINED FOR THE PORT WHOSE NUMBER IS STORED IN DESBYTE.       60680000
*PTRBUF  POINTS TO THE CHAIN BEING PRINTED NOW WHICH WILL BE RELEASED   60690000
*        BY MXWCCC BEFORE STARTING PRINTING OF THE NEXT LINE.           60700000
*PTBFA   IS THE NUMBER OF BUFFERS POINTED TO BY PTFBUF PTIBUF PTRBUF    60710000
*                                                                       60720000
*                                                                       60730000
         USING MXWCCC,8                                                 60740000
MXWCCC   LA    BA,PTRBUF           RELEASE BUFFERS MAYBE                60750000
         BAL   LINK,FREEBQ                                              60760000
         L     BA,PTFBUF           BUFFERS TO WRITE TO TERMINAL         60770000
         ST    BA,PTRBUF           RELEASE NEXT TIME                    60780000
         CLI   PTFBUF+1,EMPTYM                                          60790000
         BE    MXWEMP              NOTHING MORE TO PRINT                60800000
         LR    1,BA                BA STILL POINTS TO FIRST BUFF        60810000
         USING PERBUF,1            WILL BE LAST BUFFER OF LINE          60820000
         MVI   PBCCW,WR            WRITE COMMAND IN FIRST BUFFER        60830000
         B     *+8                                                      60840000
MXWC2    L     1,PBTIC             SEARCH FOR LAST BUFFER               60850000
         TM    PBFLAG,LINEZ        OF FIRST LINE IN CHAIN               60860000
         BZ    MXWC2                                                    60870000
         OI    PBFLAG,LISTZ        FOR FREEBUF                          60880000
         MVC   PTFBUF,PBTIC                                             60890000
         BAL   LINK,MXWOUTWK       RESET OUTWAIT MAYBE                  60900000
         MVI   PTCNT,0             CLEAR ERROR COUNT                    60910000
         MVI   STATE,WRITES                                             60920000
         TM    PBFLAG,KILLFLAG     TEST FOR SVOFF                       60970000
         BO    UNKILL1             QUEUED DISCONNECT SIGNAL             60980000
         CLI   PTTYPE,Q1050                                             60990000
         BE    MXW1050                                                  61000000
*        SAME CHAIN FOR 2741 AND 1052                                   61010000
MXW1052  LA    0,0(BA)                                                  61020000
MXWZ     ST    0,PUCCB                                                  61030000
         B     MXSION                                                   61040000
MXW1050  MVC   PTCCW1(9),WR1050AD                                       61050000
         MVI   PBCCW+4,CC+SLI      CHAIN LAST WRITE CCW                 61060000
         MVC   PBTIC,ADIAG1        ALL 1050 ANSWER CHARACTERS ARE       61070000
*                                  READ TO SAME BYTE IN STORAGE.        61080000
         ST    BA,PTCCW3           MAKE PTCCW3 TIC TO FIRST BUFFER      61090000
         MVI   PTCCW2+4,CC+SLI                                          61100000
*        ASSUME RESPONSE WILL BE CRY, CRN OR ABSENT                     61110000
         LA    0,PTCCW1                                                 61120000
         B     MXWZ                                                     61130000
         DROP  1                                                        61140000
MXWEMP   LA    LINK,SETIDL2        MXWOUTWK RETURN ADDRESS              61190000
MXWOUTWK CLI   PTFBUF+1,EMPTYM     TEST BUFFER ALMOST EMPTY             61200000
         BCR   7,LINK                                                   61210000
         TM    ACTIVE,OUTWAITM     WAS THIS PORT OUTPUT BOUND      3064 61230000
         BCR   8,LINK              NO.                             3064 61240000
         MVI   RESCH,1             POST QZA7                       3064 61250000
         NI    ACTIVE,255-OUTWAITM                                      61270000
         BR    LINK                                                     61280000
         DROP  8                                                        61290000
         SPACE 3                                                        61300000
*        COMMAND CHAINS FOR INPUT                                       61310000
*        2741 OR TS41 NORMAL INOUT                                      61320000
*PTCCW1  CCW   WR,INPCRC,CC+SLI,1                                       61330000
*PTCCW2  CCW   REINHIB,PTRESP,DC,1                                      61340000
*PTCCW3  TIC   PBCCW               OF FIRST BUFFER                      61350000
*PBCCW(1) CCW  0,PBSTAR,DC+PCI,L'PBSTAR-1                               61360000
*PBTIC(1) TIC  DISCARD                                                  61370000
*                                                                       61380000
*        2741 (TS41) AFTER ATTN KEY IN READ STATE (PSEUDO LINEFEED)     61390000
*PTCCW1  CCW   WR,Q2741LF(QTS41LF),CC+SLI,L'Q2741LF                     61400000
*PTCCW2  CCW   REINHIB,PTRESP,DC,1                                      61410000
*PTCCW3  TIC   PBCCW      OF BUFFER IN WHICH CRC LIES OR NEXT BUFFER    61420000
*        TWO POSSIBLITIES FOR REMAINDER OF 2741(TS41) PSEUDO LINEFEED   61430000
*              CHAIN DEPENDING ON BUFFER AVAILABILITY AT UNRZ30..       61440000
*        WHEN BUFFER WAS AVAILABLE                                      61450000
*PBCCW   CCW   0,1+ADDRESS OF CRC IN BUFFER,DC,RESIDUAL COUNT FROM CSW  61460000
*PBTIC   TIC   PBCCW               OF EMPTY BUFFER OBTAINED AT UNRZ30   61470000
*PBCCW   CCW   0,PBSTAR,DC+PCI,L'BPSTAR-1                               61480000
*PBTIC   TIC   DISCARD                                                  61490000
*        IF NO BUFFER WAS AVAILABLE                                     61500000
*PBCCW   CCW   0,1+ADDRESS OF CRC IN BUFFER,DC+PCI,RESIDUAL COUNT       61510000
*PBTIC   TIC   DISCARD                                                  61520000
*                                                                       61530000
*        2741(TS41) AFTER TRANSMISSION ERROR OR MISSED PCI              61540000
*PTCCW1  CCW   WR,RST2741(RSTTS41),CC+SLI,L'RST2741                     61550000
*PTCCW2  CCW   REINHIB,PTRESP,DC,1                                      61560000
*PTCCW3  TIC   PBCCW               OF FIRST BUFFER                      61570000
*PBCCW(1) CCW  0,PBSTAR,DC+PCI,L'PBSTAR-1                               61580000
*PBTIC(1) TIC  DISCARD                                                  61590000
*                                                                       61600000
*        1050  ALL CASES OF INPUT                                       61610000
*PTCCW1  CCW   WR,INPOLL,CC+SLI,5                                       61620000
*PTCCW2  CCW   REINHIB,PTRESP,DC,1                                      61630000
*PTCCW3  TIC   PBCCW               OF FIRST BUFFER                      61640000
*PBCCW(1) CCW  0,PBSTAR,DC+PCI,L'PBSTAR-1                               61650000
*PBTIC(1) TIC  DISCARD                                                  61660000
*                                                                       61670000
*        1052 MODEL 7                                                   61680000
*        PTCCW1, PTCCW2 AND PTCCW3 ARE NOT USED BY CHANNEL PROGRAM      61690000
*PBCCW   CCW   X'0A',PBSTAR,DC+PCI,L'PBSTAR-1                           61700000
*PBTIC   TIC   DISCARD                                                  61710000
*                                                                       61720000
*        NOTE THAT A PCI FROM PBCCW FOR ANY OF THE ABOVE DEVICES        61730000
*        WILL RESULT IN ASSIGNMENT AND INITIALIZATION OF ANOTHER BUFFER 61740000
*        AND REPLACEMENT OF PBTIC IN THE PARTIALLY FILLED BUFFER WITH A 61750000
*        TIC TO THE NEW BUFFER.                                         61760000
*                                                                       61770000
*        FOR A 270X DEVICE OF AMBIGUOUS TYPE THE CHAIN IS AS FOR A 1050 61780000
*        OR 2741 EXCEPT FOR THE COMMAND CODE OF PTCCW2 WHICH BECOMES    61790000
*        RETIME AND PTCCW1 WHICH TAKES ON ONE OF THE FOLLOWING VALUES.. 61800000
*PTCCW1  CCW   ENABLE,INPOLL,CC+SLI,1   AFTER A DISABLE                 61810000
*PTCCW1  CCW   WR,INPCRC+1,CC+SLI,2     ASSUMED 1050                    61820000
*PTCCW1  CCW   WR,INPCRC,CC+SLI,1       ASSUMED 2741 (TS41)             61830000
         SPACE 3                                                        61840000
*        WRITE ANSWER CCW CHAIN FOR USE AFTER SUCCESSFUL COMPLETION     61850000
*        OF AN INPUT CCW CHAIN.                                         61860000
*        2741 AND TS41                                                  61870000
*WCRDI   CCW   WR,CRD AND IDLES,SLI,1 MAX IDLMAX MIN 2*PTBFA            61880000
*        1050                                                           61890000
*PTCCW1  CCW   WR,BLKADR,CC+SLI,5     FROM BLKCCW1                      61900000
*PTCCW2  CCW   RETIME,PTRESP,CC+SLI,1                                   61910000
*PTCCW3  TIC   BLKCCW3                                                  61920000
*                                                                       61930000
*        1052 DOES NOT NEED AN ANSWER CHAIN                             61940000
         SPACE 3                                                        61950000
*        OUTPUT CCW CHAINS                                              61960000
*        A SIO WILL BE ISSUED TO PRINT A SINGLE LINE USING BUFFERS      61970000
*        OBTAINED AND FILLED BY TYOSUB.  EVERY BUFFER EXCEPT THE LAST   61980000
*        HAS A FLAGS FIELD OF DC, AN ADDRESS OF PBSTAR AND A COUNT OF   61990000
*        L'PBSTAR.  THE LAST BUFFER MAY HAVE A SHORT COUNT AND A        62000000
*        DEVICE DEPENDENT FLAGS FIELD.  IN THE MODEL CHAINS BELOW, (F)  62010000
*        INDICATES FIRST BUFFER, (L) INDICATES LAST BUFFER              62020000
*                                                                       62030000
*        2741, TS41 OR 1052 WRITE CHAIN                                 62040000
*PBCCW(F) CCW  WR,PBSTAR,DC,L'PBSTAR                                    62050000
*PBTIC(F) TIC  TO NEXT BUFFER                                           62060000
*PBCCW(L) CCW  0,PBSTAR,SLI,POSSIBLE SHORT COUNT                        62070000
*PBTIC(L)   UNDEFINED                                                   62080000
*PBSTAR(L)  IS FILLED OUT WITH ENOUGH IDLE CHARACTERS FOR CARRIAGE RET  62090000
*                                                                       62100000
*        1050 WRITE CHAIN                                               62110000
*PTCCW1  CCW   WR,OUTADR,CC+SLI,3                                       62120000
*PTCCW2  CCW   RETIME,PTRESP,CC+SLI,1                                   62130000
*PTCCW3  TIC   PBCCW(F)                                                 62140000
*PBCCW(F) CCW  WR,PBSTAR,DC,L'PBSTAR                                    62150000
*PBTIC(F) TIC  TO NEXT BUFFER                                           62160000
*PBSTAR(F) BEGINS WITH AL1(CRD)                                         62170000
*PBCCW(L) CCW  0,PBSTAR,CC+SLI,POSSIBLE SHORT COUNT                     62180000
*PBTIC(L) TIC  DIAG1               TO READ ANSWER                       62190000
*PBSTAR(L) ENDS WITH A AL1(CRB)                                         62200000
         SPACE 3                                                        62210000
*        DISCONNECT SEQUENCES                                           62220000
*        DIALUP 270X DEVICES                                            62230000
*PTCCW1  CCW   DISABLE, ,CC+SLI,EITHER 1 3 OR 5                         62240000
*PTCCW2  CCW   PTSAD,PTRESP,SLI,1                                       62250000
*        NONDIALUP 270X DEVICES                                         62260000
*PTCCW1  CCW   ENABLE, ,CC+SLI,EITHER 1 3 OR 5                          62270000
*PTCCW2  CCW   PTSAD,PTRESP,SLI,1                                       62280000
         SPACE 3                                                        62290000
*                                                                       62300000
*        BLACK CCWS ARE USED AT UNRZ12 TO FORM A CCW CHAIN TO GET 1050  62310000
*        INTO BLACK SHIFT.  CAHIN IS STORED IN PTCCW1 THRU PTCCW4 AND   62320000
*        ISSUED WITH TERMINAL IN WRITES STATE.                          62330000
WCRDI    CCW   WR,KCRD,SLI,0       SEE UNRZ4 FOR COUNT LOGIC $ $ $ $ $  62340000
DISCARD  CCW   0,SKADISC,DC+SLI+SKIP+PCI,L'SKADISC                      62350000
         DC    A(TIC*F*F*F+DISCARD)                                     62360000
TBLKCCW3 DC    A(TIC*F*F*F+BLKCCW3)                                     62370000
KMXWIS   DC    H'10'               TYOSUB SUBTRACT FROM CHAR COUNT      62380000
KRZIS    DC    H'40'               UNRZ4 SUBTRACT FROM INPUT COUNT      62390000
KRZID    DC    F'10'               UNRZ4 DIVISOR IN IDLE COMPUTATION    62400000
BLKCCW1  CCW   WR,BLKADR,CC+SLI,5  PTCCW1                               62410000
         DC    AL1(RETIME)         PTCCW2 COMMAND BYTE                  62420000
*        INPOLL ASSUMES 1050 IS ALREADY IN RED SHIFT OR THAT PREVIOUS   62430000
*        OPERATION WAS WRITE TO PRINTER1.                               62440000
INPOLL   DC    X'3E62'             PREFIX,A   FOR REDSHIFT              62450000
INPCRC   DC    AL1(CRC)                                                 62460000
         DC    X'6215'             A,ZERO  COMMON POLL                  62470000
BLKDATA  DC    AL1(CRD,X'3E',X'64',CRB)   BLACK SHIFT SEQUENCE          62480000
*        RESEND TEXT FOR BOTH KINDS OF 2741                             62490000
RST2741  DC    AL1(CRD)            SET RECEIVE TEXT MODE IN 2741        62500000
         DC    15X'7F'             IDLES PREVENT OVERPRINT         3587 62510000
         DC    X'4A295229252A5B'   GENUINE 2741                         62520000
         DC    AL1(CRC)            SET TRANSMIT TEXT MODE IN 2741       62530000
LRSTXT   EQU   *-RST2741                                                62540000
LASTBUF  DC    A(0)                UNRZ TEMP CELL                       62550000
BLKCCW3  CCW   X'01',BLKDATA,CC+SLI,4  PTCCW3                           62560000
DIAG1    CCW   RETIME,SKADIAG,SKIP+SLI,1                                62570000
WR1050AD CCW   X'01',OUTADR,CC+SLI,3  NORMAL 1050 WRITE PTCCW1          62580000
         DC    AL1(RETIME)         PTCCW2 COMMAND BYTE                  62590000
RSTTS41  DC    AL1(CRD)                                                 62600000
         DC    15X'7F'             IDLES PREVENT OVERPRINT         3587 62610000
         DC    X'526B256B4A685B'   TSS 2741                             62620000
         DC    AL1(CRC)                                                 62630000
BLKADR   DC    AL1(CRD,X'DF',CRC)  CRD= READ ANSWER                     62640000
*                                  X'DF' IS ALL MARKS CHARACTER FOR     62650000
*                                        UNATTENDED 1050S               62660000
*                                  CRC=POLLING CHARACTER ONE            62670000
         DC    X'6213'             BCD A,9 TRANSMIT TO ALL RCV COMPONE  62680000
*        NOTE... THE FIRST 96 IS A CRD, THE SECOND AN INVERTED CARET.   62690000
OUTADR   EQU   BLKADR+2            NORMAL WRITE ADDRESSING SEQUENCE     62700000
*                                                                       62710000
Q2741LF  DC    X'96BB96DDBB1F'                                          62720000
QTS41LF  DC    X'96BB93DDBB1F'                                          62730000
KCRD     DC    AL1(CRD)            FOLLOWED BY IDLE CHARACTERS          62740000
         DC    (IDLMAX-1)X'7F'     ENOUGH IDLES FOR 2741                62750000
         DC    5X'7F'              MORE IDLES FOR TYOSUB                62760000
*        FOLLOWING DATA AREAS ARE FOR THE USE OF THE MULTIPLEXOR SUB-   62770000
*        CHANNEL                                                        62780000
SKALIRS  DC    XL4'00'             LIRS2741                             62790000
SKAPREP  DC    X'00'               PREPCCW                              62800000
SKADISC  DC    XL9'00'             DISCARD                              62810000
SKADIAG  DC    X'00'               DIAG1                                62820000
*        DIFFERENT AREA FOR EACH COMMAND SO NON-ZERO CONTENTS CAN BE    62830000
*        TRACED DOWN TO CULPRIT.                                        62840000
*                                                                       62850000
RKEY     PHGEN 150,150,8           RAW INPUT CHARACTER COUNT            62860000
*                                                                       62870000
ARIV     PHGEN 36300,122,9         INPUT ARRIVAL TIME                   62880000
*                                                                       62890000
OUTL     PHGEN 150,150,10          INTERNAL OUTPUT CHARACTER COUNT      62900000
*                                                                       62910000
*                                                                       62920000
*        SIGN OFF AND DROP LIN E                                        62940000
SVOFF0   BALR  10,0                TRANSMUTED )OFF HOLD                 62950000
         USING SVOFF,10                                                 62960000
SVOFF    CLI   PTTYPE,Q103A                                             62970000
         BH    SVOFFH1             TRANSMUTE TO )OFF HOLD               62980000
* TREAT MODEM LIKE DIALUP IF SHUTDOWN HAS BEEN EXECUTED.           P056 62990000
         CLI   SHUTDOWN,0          SHUTDOWN?                       P056 63000000
         BNE   SVOFF1              YES.                            P056 63010000
* OTHERWISE TREAT MODEM LIKE  )OFF HOLD                            P056 63020000
         TM    IOB2,Q4WMDM                                              63030000
         BO    SVOFFH1             TRANSMUTE TO )OFF HOLD               63040000
SVOFF1   EQU   *                                                   P056 63050000
         OI    IOB1,NSIGNM         FOR SATSUB USE                       63060000
         BAL   LINK,TYORAT         COMPUTE BUFFER RATION                63070000
         LA    3,SVOFFM            EXCUSE TO ENTER TYOSUB               63080000
         BAL   LINK,TYOSUB         GET ONE BUFFER NEATLY                63090000
         B     SETBUFWQ            SVOFF MACRO GENERATES SIX BYTES      63100000
         BAL   LINK,TYOINS         APPEND TO CHAIN                      63110000
         LR    BA,0                POINT TO BUFFER AGAIN                63120000
         OI    PBFLAG-PERBUF(BA),KILLFLAG                               63130000
         BAL   LINK,INITMWR        IN CASE CHANNEL IS IDLE              63140000
         BAL   LINK,OFFSUB         LOSE WORKSPACE ETC.                  63150000
         B     QUEND                                                    63160000
SVOFFM   DC    H'1'                SOMETHING FOR TYOSUB                 63170000
         DC    AL1(ZY,ZEOB)        (NEVER PRINTED)                      63180000
*                                                                       63190000
*        SVC REQUESTING ANY OF                                          63200000
*              LOAD, DROP, SAVE, COPY, SIGNOFF, LIBRARY                 63210000
         USING SVSDREQ,10                                               63220000
SVSDREQ  CLI   SDT+1,EMPTYM                                             63230000
         BE    SVSDR1             NO SPECIAL DISK OP GOING NOW          63240000
SVSDR6   MVI   MISCB,SDWAIT        SD OP IN PROGRESS, WAIT FOR SDKILL   63250000
         PTSET MISCB                                                    63260000
         OI    ACTIVE,MISCM                                             63270000
         B     BACK6               -6 TO PSW                            63280000
SVSDR1   TM    IOB1,COPYRM+COPYWM  DETECT ANY COPY WE FORGOT TO END     63290000
         UGH   NZ                  MEANS MAJOR CRISIS                   63300000
         L     1,REGSV                                                  63310000
         CLI   PDSOPA-PDSLIB(1),XXCOPY   LOOK FOR COMMANDS WHICH NEED   63320000
         BNE   SVSDR4              NOT COPY                             63330000
         CLI   COPSINK+1,EMPTYM    PERMIT ONE COPY AT A TIME            63340000
         BNE   SVSDR6              SET SDWAIT                           63350000
         ST    PTR,COPSINK         MARK AS COPY SINK                    63360000
         LA    4,PDSLEN+L'PDSID    MOVE COPY PARAMETER                  63370000
         B     SVSDR2                                                   63380000
SVSDR4   LA    4,PDSLEN            DO NOT MOVE COPY PARAMETER           63390000
         CLI   PDSOPA-PDSLIB(1),XXLIB  EXTRA SWAPPING DISK              63400000
         BNE   SVSDR2                                                   63410000
SVSDR3   CLC   LIBNOW+1(1),LIBLIM+1 WE CAN ONLY HANDLE SO MANY          63420000
         BNL   BACK6               TWO-WORKSPACE OPERATIONS AT ONCE.    63430000
*                                  IF LIMIT IS EXCEEDED, DON'T RUN THIS 63440000
*                                  GUY BUT LET HIM KEEP HAMMERING AT US 63450000
         LH    2,LIBNOW            BUMP )LIB COUNT                      63460000
         LA    2,1(2)                                                   63470000
         STH   2,LIBNOW                                                 63480000
*        START SPECIAL DISK OPERATION                                   63490000
SVSDR2   ST    PTR,SDT                                                  63500000
         MVC   SDQZSW(8),GETDIR   GET DIRECTORY INTO CORE               63510000
         OI    ACTIVE,LOCKM       FORCE CONTINUED CORE RESIDENCE        63520000
         NI    IOB1,255-TRREJ      MARK AS ACCEPTED                     63530000
         MVC   SVOLDPSW+4(4),=A(SDRET)                                  63540000
         L     2,RRCORE                                                 63550000
         MVI   PCQUONT-PERCORE(2),X'F0'                                 63560000
         L     8,ASDPAR            SPECIAL DISK PARAM AREA IN DSEARCH   63570000
         USING PDSDDDD,8                                                63580000
         EX    4,SVSDRMVC                                               63590000
         MVC   SDOP(1),PDSOPA      PDSOPA IS IN TYPEWRITER BUFFER       63600000
         MVC   PDSOP,SDOP          PDSOP IS BELOW TYPEWRITER BUFFER     63610000
         LH    HISTVAL,SDOP-1                                           63620000
         CLI   SDOP,XXMAX                                               63630000
         BH    SVILG               ILLEGAL SVC, SPECIAL DISK            63640000
         LA    PHR,PERHSD                                               63650000
         BAL   LINK,HISTCOMP                                            63660000
         CLI   SDOP,XXSAVE                                              63670000
         BNE   QUEND                                                    63680000
         L     4,LIBBASE                                           2221 63690000
         COPY  TRCOMP                                                   63700000
         STH   1,PDSTCNT-1         FOR SAVE DIRECTORY SEARCH            63710000
         B     QUEND                                                    63720000
         DROP  4                                                        63730000
SVSDRMVC MVC   PDSDDDD,0(1)                                             63740000
         DROP  8                                                        63750000
         USING REMCDC,7                                            DASD 63760000
REMCDC   REMCDC ,                                                  DASD 63770000
*                                                                       63790000
*                                                                       63800000
*        TRANSMIT MESSAGE TO LOG                                        63820000
         USING SVLOG,10                                                 63830000
SVLOG    LA    10,SVTRAN           CHANGE BASE REG                      63840000
         USING SVTRAN,10                                                63850000
         CLI   OPNUM,X'FF'         CHECK FOR OPERATOR NOT SIGNED ON     63860000
         BE    SVLOG1                                                   63870000
         MVI   MSGTEM,0            DESTINATION                          63880000
         L     1,OPTERM            OPR IS LOG FOR NOW                   63890000
         B     SVTRAN1                                                  63900000
*        TRANSMIT MESSAGE TO SOME TERMINAL                              63910000
SVTRAN   CLI   REGSV+7,0           MESSAGE TO TERMINAL ZERO IS CHANGED  63920000
         BNE   *+10                INTO MESSAGE TO OPERATOR'S PORT NUMB 63930000
         MVC   REGSV+7(1),OPNUM    NUMBER OF OPERATOR'S PORT            63940000
         CLC   REGSV(4),ZERO                                            63950000
         BE    SVOPGL              SPECIAL GLITCH                       63960000
*        ASSUME CALLING SEQUENCE IS SIMILAR TO TYO                      63970000
*        L     1,TERMNUMBER       0 LEQ R1 LEQ TERMCOUN                 63980000
*        LA    0,INTERNAL BUFFER                                        63990000
*        SVCC  YYTRAN                                                   64000000
*        NOW SET FLAGS FOR ADDRESSEE                                    64010000
         BAL   LINK,VALTERM        GET BASE REGISTER                    64020000
         B     SVTYOT              OUT OF RANGE, REJECT                 64030000
SVTRAN1  EQU   *                   AT THIS POINT MSGTEM WILL BE ZERO    64040000
*        IFF ORIGINAL SVC WAS YYLOG.  DESBYTE = 0 IS USED IN SATSUB TO  64050000
*        AVOID SETTING ATTENTION WHEN A TERMINAL IS SUSPENDED TRYING TO 64060000
*        TRANSMIT TO THE LOG.                                           64070000
*        CURRENT VERSION OF RECMSUB ALLOWS OPERATOR TO RECEIVE MESSAGES 64080000
*        TO THE LOG.                                                    64090000
         CR    1,PTR                                                    64100000
         BE    SVTYOT              MESSAGE TO SELF, REJECT              64110000
         LA    BA,PTIBUF             FREE INPUT BUFFER                  64120000
         BAL   LINK,FREEBQ                                              64130000
         DROP  PTR                CHANGE TO DESTINATION                 64140000
         USING PERTERM,1                                                64150000
         TM    MISCB,NOWSM         SEE IF THIS TERMINAL HAS WORKSPACE   64160000
         BO    SVTYOT              NOWORKSPACE, REJECT                  64170000
         DROP  1                                                        64180000
         USING PERTERM,PTR                                              64190000
         BAL   LINK,TYORAT         USE SENDER'S PTBFA IN RATION COMP    64200000
         LR    PTR,1               USE DESTINATION PTTYPE               64210000
         L     3,REGSV             POINT TO INTERNAL BUFFER             64220000
         BAL   LINK,TYOSUB                                              64230000
         B     SVMSG3              INSUFFICENT BUFFERS                  64240000
         TM    MISCB,TRAWAITM+REPWAITM                                  64250000
         BNZ   SVMSG7              IN MESSAGE SUSPENSION, SEND IT NOW   64260000
SVMSG2A  LR    1,PTR                                                    64270000
         L     PTR,PTBASE                                               64280000
SVMSG2   OI    IOB1-PERTERM(1),RINGM  MARK AS MESSAGE PENDING           64290000
         OI    MISCB,TRAWAITM                                           64300000
         OI    ACTIVE,MISCM                                             64310000
         MVC   DESBYTE,MSGTEM      FOR SEARCH AT SVRECM4                64320000
         LH    0,BUFTS                                                  64330000
         AH    0,PTBFA             UPDATE COUNT OF BUFFERS OWNED BY     64340000
         STH   0,PTBFA             SENDING TERMINAL                     64350000
         MVC   PTIBUF,FBUF         POINT TO MESSAGE                     64360000
         BAL   LINK,RECMSUB        SENDER TRYS TO RECEIVE               64370000
         B     QUEND               AWAIT TRANSMISSION                   64380000
SVMSG3   L     PTR,PTBASE          RESTORE PTR BEFORE SETTING OUTWAITM  64390000
         B     STYONO                                                   64400000
*        DESTINATION IS IN EITHER TRAWAIT OR REPWAIT                    64410000
SVMSG7   BAL   LINK,TYOINS         DEST GETS MESSAGE                    64420000
         BAL   LINK,INITMWR        START OUTPUT IF NEEDED               64430000
         TM    IOB2,RECMM          DON'T DESUSPEND TERM IN PERMANENT-   64440000
         BO    SVMSG4              RECEIVE STATE                        64450000
         NI    MISCB,255-REPWAITM                                       64460000
         BNZ   SVMSG4              IN TRANSMIT WAIT                     64470000
         NI    ACTIVE,255-MISCM    BREAK REPWAIT                        64480000
SVMSG4   L     PTR,PTBASE          RESTORE SENDER'S PTR.                64490000
*        FALL INTO SVRECM                                               64500000
         DROP  10                                                       64510000
*                                                                       64520000
*        INTERPRETER WISHES TO RECEIVE MESSAGES NOW                     64530000
SVRECM   BAL   LINK,RECMSUB                                             64540000
         TM    IOB1,BROADM IF PA STILL PENDING DUE TO BUFFER RATION3039 64550000
         BO    SETBUFWQ   SET OUTWAIT (BUFFWAIT) AND RETRY LATER   3039 64560000
*        NOTE MUST HAVE INTERRUPTS DISABLED TO PREVENT ENQUE OF    3039 64570000
*  NOTE FROM UNDERGROUND HERE ELSE SCHEDULER WILL BE SUSPENDED     3039 64580000
         B     SVEXIT                                                   64590000
*                                                                       64600000
*        GLITCH TO LOCK OPERATOR'S KEYBOARD                             64610000
SVOPGL   BAL   LINK,RECMSUB        RECEIVE MESSAGES                     64620000
         MVI   MISCB,REPWAITM      SUSPEND ALLOWING MESSAGE RECEIPT     64630000
         PTSET MISCB                                                    64640000
         OI    ACTIVE,MISCM                                             64650000
         B     QUEND                                                    64660000
*                                                                       64670000
*        SVC YYLOG WITH OPERATOR NOT SIGNED ON                          64680000
SVLOG1   LA    3,5*300             WAIT FIVE SECONDS                    64690000
         BAL   5,TERMDEL           SET CLOCKWAIT                        64700000
         B     BACK6               AND THEN RETRY THE SVC               64710000
*                                                                       64720000
*                                                                       64730000
*        BODY OF RECMSUB (MESSAGE RECPTION SUBROUTINE)                  64740000
         USING REMRECM,10                                               64750000
REMRECM  ST    LINK,MXTEM12+8                                           64760000
         CL    PTR,OPTERM          SPECIAL MESSAGE                      64770000
         BE    SVRECM3             RECEPTION TECHNIQUES FOR OPERATOR    64780000
         TM    IOB1,BROADM                                              64790000
         BZ    SVRECM1             MUST BE ADDRESSED MESSAGE            64800000
         BAL   LINK,TYORAT        RATION FOR PA MSG                3039 64810000
         L     3,BROADPT          BROADCAST MESSAGE POINTER             64820000
         BAL   LINK,TYOSUB                                              64830000
         B     SVRECM12       IGNORE PA TEMPORARILY,RECEIVE MSGS   3039 64840000
         BAL   LINK,TYOINS         ATTACH BROADCAST MESSAGE             64850000
         NI    IOB1,255-BROADM     BROADCAST IS ACCEPTED                64860000
SVRECM12 TM    IOB1,RINGM         TEST FOR ADDRESSED MSGS          3039 64870000
         BZ    SVRECM2             EXIT                                 64880000
SVRECM1  BAL   2,CVTERM            SET R1= TERMINAL NUMBER              64890000
SVRECM11 STC   1,SVRECM4+1         PROG MODIFICATION $ $ $ $ $ $        64900000
         LM    0,2,PTBXLE                                               64910000
SVRECM4  CLI   DESBYTE-PERTERM(2),C'*'   MODIFIED ABOVE  $$$$$$$$$$     64920000
         BE    SVRECM5  WE HAVE FOUND A TERMINAL TO RECEIVE FROM        64930000
SVRECM7  BXLE  2,0,SVRECM4                                              64940000
         CLI   SVRECM4+1,0                                              64950000
         BE    SVRECM1             SECOND PASS FOR OPTERM               64960000
         NI    IOB1,255-RINGM                                           64970000
SVRECM2  L     LINK,MXTEM12+8                                           64980000
         CLI   PTFBUF+1,EMPTYM     SEE IF SIO IS NEEDED                 64990000
         BCR   8,LINK              NO INSERTIONS WERE MADE              65000000
         B     INITMWR             INITIATE WRITE BEFORE RETURN         65010000
SVRECM5  STM   0,2,MSGTEM                                               65020000
         USING PERTERM,2                                                65030000
         DROP  PTR                                                      65040000
*        MAKE CERTAIN THAT THIS TERMINAL REALLY HAS A MESSAGE FOR US    65050000
         TM    MISCB,TRAWAITM                                           65060000
         BZ    SVRECM8             SYSTEM ERROR, IGNORE                 65070000
         L     BA,PTIBUF           SETUP FOR TYOINS                     65080000
         ST    BA,FBUF             HEAD OF BUFFER CHAIN PARAMETER       65090000
         MVI   PTIBUF+1,EMPTYM     MARK EMPTY TO INHIBIT RELEASE        65100000
         USING PERBUF,BA                                                65110000
         SR    0,0                                                      65120000
         B     *+8                                                      65130000
         L     BA,PBTIC            LOCATE END OF LIST                   65140000
         AH    0,KHONE             COUNT BUFFERS IN THIS MESSAGE        65150000
         TM    PBFLAG,LISTZ                                             65160000
         BZ    *-12                LOOP BACK                            65170000
         STH   0,BUFTS             FAKE PRIOR TYOSUB FOR TYOINS         65180000
         LH    1,PTBFA             DECREMENT SENDER'S COUNT             65190000
         SR    1,0                                                      65200000
         STH   1,PTBFA                                                  65210000
         BAL   LINK,TYOINS         ATTACH TO BUFFER                     65220000
         DROP  BA                                                       65230000
*        MESSAGE IS IN PTR BUFFER, CLEAR SENDER FLAGS                   65240000
         LM    0,2,MSGTEM                                               65250000
         NI    MISCB,255-TRAWAITM   RELEASE SUSPENSION                  65260000
         NI    ACTIVE,255-MISCM                                         65270000
SVRECM8  MVI   DESBYTE,X'FF'       MARK AS NO MESSAGES                  65280000
         B     SVRECM7                                                  65290000
         DROP  2                  PRESTORE NORMAL BASE REGISTERS        65300000
         USING PERTERM,PTR                                              65310000
SVRECM3  TM    IOB1,BROADM         OPERATOR DOES NOT GET PA'S           65320000
         BZ    SVRECM6             NO N FROM U WAITING                  65330000
         MVC   FBUF,NUFBUF         RECEIVE A NOTE FROM THE UNDERGROUND  65340000
         L     BA,NULBUF           FAKE A PRIOR TYOSUB                  65350000
         MVI   NUFBUF+1,EMPTYM     MARK NOTES FROM UNDERGROUND EMPTY    65360000
         MVC   BUFTS,NUBFA         NOTE FROM UND BUFFER COUNT           65370000
         MVC   NUBFA,ZERO                                               65380000
         BAL   LINK,TYOINS         ATTACH NOTES TO OPERATOR TERMINAL    65390000
         NI    IOB1,255-BROADM                                          65400000
*        OPTERM MAKES TWO COMPLETE PASSES THROUGH THE SVRECM4, SVRECM7  65410000
*        LOOP.  THE FIRST PASS IS WITH SVRECM4+1 SET TO ZERO TO RECEIVE 65420000
*        LOG MESSAGES.  THE SECOND PASS USES THE TRUE TERMINAL NUMBER   65430000
*        OF THE OPERATOR TO RECEIVE ORDINARY MESSAGES TO THE OPERATOR.  65440000
SVRECM6  SR    1,1                 TERM ZERO                            65450000
         B     SVRECM11                                                 65460000
         DROP  10                                                       65470000
*        LOAD EMPTY WORKSPACE REQUEST FROM INTERPRETER                  65500000
SVLEMP   LR    4,PTR                                                    65510000
         BAL   LINK,WSLOSE         DISCARD OLD WORKSPACE                65520000
         BAL   LINK,LEMP           START OR ENQUE READ EMPTY OP         65530000
         MVC   PTCORE+2(2),REGSV+2  POSSIBLE DIRECTORY NUMBER           65540000
         B     QUEND                                                    65550000
*                                                                       65560000
*        SVC TO TERMINATE A )LIB OPERATION                              65570000
*        PTR POINTS TO TERMINAL                                         65580000
*        PXR (CURRENTM) POINTS TO DIRECTORY IN CORE                     65590000
*        CONCEAL POINTS TO A PERDISK FOR THE REAL WORKSPACE             65600000
SVLIBZ   L     1,CONCEAL           REAL WS WAS SWAPPED OUT AND HIDDEN   65610000
         MVC   PDTERM+1-PERDISK(3,1),PTBASE+1  RESTORE PDTERM           65620000
         L     1,RRCORE            DESTROY CORE COPY OF DIRECTORY       65630000
         MVI   PCTERM+1-PERCORE(1),EMPTYM                               65640000
         MVI   PTCORE+1,EMPTYM                                          65650000
         LH    0,LIBNOW            DECREMENT THE COUNT OF )LIB OPS      65660000
         BCTR  0,0                 CURRENTLY IN PROGRESS                65670000
         STH   0,LIBNOW                                                 65680000
         B     QUEND                                                    65690000
         SPACE                                                          65700000
*                                                                       65710000
*        APL SHUTDOWN.                                                  65720000
*        SET FLAG TO INHIBIT ENABLE COMMANDS.                           65730000
*        DROP LINES WITH NO WORKSPACE ASSIGNED.                         65740000
*                                                                       65750000
         USING SVEOD,10                                                 65760000
SVEOD    MVI   SHUTDOWN,1          SHUTDOWN NOW IN PROGRESS.            65770000
         LA    PTR,APLCNCL                                              65780000
         CLI   REGSV+3,0           LOW BYTE OF INTERPRETER R0 = 0       65790000
         BCR   7,PTR BNER          MEANS INITIATE SHUTDOWN, ELSE MAKE   65800000
*                                  A MAD DASH TO PUT SYSTEM BACK INTO   65810000
*                                  A PRESENTABLE SHAPE.                 65820000
         LM    4,6,PTBXLE                                               65830000
         B     SVEOD2              SKIP COPY SOURCE PERTERM.            65840000
SVEOD1   LR    PTR,6                                                    65850000
         USING PERTERM,PTR                                              65860000
         CLI   PTTYPE,Q103A        ASSUME OPERATOR WILL SHUT DOWN       65870000
         BH    SVEOD2              NON-270X TERMINALS.                  65880000
         CLI   MISCB,NOWSM         CHECK FOR WORKSPACE ASSIGNED.        65890000
         BNE   SVEOD2              SKIP HIO IF WS IS THERE OR ON THE WA 65900000
         TM    STATE,DVBUSY        SEE IF THE SUBCHANNEL IS RUNNING.    65910000
         MVI   STATE,TODROP        DISABLE AT NEXT INTERRUPT.           65920000
         BZ    SVEOD2              SKIP HIO IF NOT.                     65930000
         OI    STATE,DVBUSY        PRESERVE RUNNING FLAG.               65940000
         MVI   PTFBUF+1,EMPTYM     MIGHT NEVER HAVE BEEN TO MXRCCC.     65950000
         BAL   LINK,HIOSUB         HALT CURRENT IO.                     65960000
SVEOD2   BXLE  6,4,SVEOD1                                               65970000
         B     SVEXIT                                                   65980000
*                                                                       65990000
*        SET SIGN ON MESSAGE                                            66000000
*                                                                       66010000
SVSOM    L     1,REGSV             MOVE SIGN-ON MESSAGE INTO BUFFER     66020000
         L     2,SOMPT                                                  66030000
         MVC   0(130,2),0(1)                                            66040000
         B     SVEXIT                                                   66050000
*                                                                       66060000
         USING SVDEL,10                                                 66070000
*        SUSPEND THIS TERMINAL UNTIL INTERVAL EXPIRES                   66080000
SVDEL    L     3,REGSV             R0 IS TIME IN SEC DIV 300            66090000
SVDEL1   BAL   5,TERMDEL           SUSPEND AND SET DELAY                66100000
         B     QUEND                                                    66110000
         DROP  10                                                       66120000
         EXITPC                                                         66140000
*                                                                       66150000
*        ATTEMPT TO COMPENSATE FOR MISSING INTERRUPT OR HIO             66160000
*        TERMINAL NUMBER IN INTRP R0                                    66170000
         USING SVRESET,10                                               66180000
SVRESET  BAL   LINK,VALTERM        GET PTR SETTING                      66190000
         B     SVEXIT              INVALID TERM NUMBER                  66200000
         LR    PTR,1               RESET THIS TERM                      66210000
         TM    STATE,DVBUSY                                             66220000
         BZ    SVRST1              SIO WITH PUCCB AS CAW                66230000
         BAL   LINK,HIOSUB                                              66240000
         B     SVEXIT                                                   66250000
SVRST1   LA    8,MXSIOQ                                                 66260000
         BAL   LINK,INITM1         CALL MPX CODE                        66270000
         B     SVEXIT                                                   66280000
         DROP  10                                                       66290000
*                                                                       66300000
         USING SVBOUNC,10                                               66310000
*        BOUNCE A USER OFF THE MACHINE                                  66320000
*        TERMINAL NUMBER IN INTRP R0                                    66330000
SVBOUNC  BAL   LINK,VALTERM                                             66340000
         B     SVEXIT              INVALID NUMBER                       66350000
         LR    PTR,1               PTR POINTS TO BOUNCEE                66360000
         LA    8,SVEXIT                                                 66370000
         B     BOUNSUB                                                  66380000
         DROP  10                                                       66390000
*                                                                       66400000
*                                                                       66410000
         USING SVBROAD,10                                               66430000
*        BROADCAST MESSAGE TO ALL TERMINALS                             66440000
SVBROAD  L     1,REGSV                                                  66450000
         L     2,BROADPT                                                66460000
         MVC   0(130,2),0(1)    STORE MESSAGE TEXT (INTERNAL CODE)      66470000
         LM    0,2,PTBXLE                                               66480000
         B     SVBR1                                                    66490000
SVBR2    LR    PTR,2                                                    66500000
         TM    IOB1,NSIGNM         AVOID BROADCAST                 BAM8 66510000
         BNZ   SVBR1               IF NOT SIGNED ON                BAM8 66520000
         CL    2,OPTERM            DON'T BROADCAST TO THE OPERATOR.     66530000
         BE    SVBR1                                                    66540000
         OI    IOB1,BROADM                                              66550000
         NI    MISCB,255-REPWAITM  WAIT FOR REPLY                       66560000
         BNZ   SVBR1                                                    66570000
         NI    ACTIVE,255-MISCM                                         66580000
SVBR1    BXLE  2,0,SVBR2                                                66590000
         B     SVEXIT                                                   66600000
         DROP  10                                                       66610000
*                                                                       66620000
         USING SVDSZ,10                                                 66630000
*        END OF DIRECTORY SEARCH                                        66640000
SVDSZ    L     1,REGSV+4*13        POINTER TO DIRSEAR WORKING STORE     66650000
         MVC   DIRSMAN(15),16(1)                                   DASD 66660000
         EX    0,SDSWRSET          RESET SPECIAL DISK SWITCH            66670000
*                                                                       66680000
*        RESET STORAGE KEYS TO PREVENT PROTECTION CHECK ON DISK.        66690000
*                                                                       66700000
         IC    3,INACTKEY          KEY OF PARTITION.                    66710000
         LR    6,PXR               M.                                   66720000
         BAL   LINK,SSKSUB         RESET STORAGE KEYS                   66730000
         L     4,HDCORE                                                 66740000
         MVI   PCQUONT-PERCORE(4),0  DECREASE CORE RES PRIORITY         66750000
         OI    ACTIVE,LOCKM        SUSPEND DURING DIRECTORY WRITE       66760000
         LH    2,SDOP-1                                                 66770000
         LH    10,SDTAB(2)                                              66780000
         DEREL ,                   DERELATIVIZE                         66790000
         DROP  10                                                       66800000
         BALR  LINK,10             USE DIRECTORY SEARCH RESULT          66810000
         B     QUEND                                                    66820000
         PRINT NOGEN                                                    66830000
SDTAB    DCY   DSZDROP             DROP                                 66840000
         DCY   DSZSAVE             SAVE                                 66850000
         DCY   DSZLOAD             LOAD                                 66860000
         DCY   DSZCOPY             COPY                                 66870000
         DCY   DSZDROP             ADD                                  66880000
         DCY   SVILG                                                    66890000
         DCY   SVILG                                                    66900000
         DCY   DSZOFF              SIGN OFF SAVE AND ACCOUNTING         66910000
         DCY   DSZDROP             DELETE USER                          66920000
         DCY   DSZDROP             USER LOCKOUT                         66930000
         DCY   DSZDROP             USER REDEMPTION                      66940000
         DCY   DSZDROP             PASSWORD CHANGE                      66950000
XXMAX    EQU   *-2-SDTAB                                                66960000
         PRINT GEN                                                      66970000
*                                                                       66980000
         USING SVSOOK,10                                                66990000
*        SIGN ON MESSAGE HAS BEEN EXAMINED                              67000000
*        MOPUP AFTER VALID SIGN ON MESSAGE                              67010000
SVSOOK   MVC   PTABTM(8),ZERO     MESSAGE VALIDATION IS FREE            67020000
         MVC   PTMTIM3(4),ZERO     INITIALIZE CUMULATIVE KEYING TIME.   67030000
         MVC   PTSOTM,PTMTIME     LINE CHARGE TIME                      67040000
         MVI   MISCB,0                                                  67050000
         PTSET MISCB                                                    67060000
         NI    IOB1,255-NSIGNM                                          67070000
         MVI   PTDAYSON,0          NUMBER OF DAYS SIGNED ON.            67080000
         L     1,REGSV+8           TYPEIN R2                            67090000
         USING PERLIB,1                                                 67100000
         MVC   PTMAN,LIBNUM                                             67110000
         MVC   PTWSQ(4),MANWSQ                                          67120000
*        MOVE FIRST THREE CHARACTERS OF HISNAME INTO PERTERM.           67130000
         LA    2,3                                                      67140000
SVSOOK2  IC    0,HISNAME(2)                                             67150000
         EX    2,SVSOOKCL          INSERT TRAILING BLANKS IF SHORT NAME 67160000
         BNL   *+8                                                      67170000
         LA    0,ZBLANK                                                 67180000
         STC   0,PTMANI-1(2)                                            67190000
         BCT   2,SVSOOK2                                                67200000
         MVC   PTCPULIM(2),SRALIM  CPU TIME LIMIT.                      67210000
         MVC   PTCPULM2(2),PTCPULIM BOTH PLACES.                        67220000
         DROP  1                                                        67230000
         CLI   REGSV+7,1           TYPEIN R1                            67240000
         BNE   SVSOOK1                                                  67250000
         ST    PTR,OPTERM          THIS IS SIGN ON OF OPERATOR          67260000
         BAL   2,CVTERM                                                 67270000
         STC   1,OPNUM             FOR MESSAGES TO TERM ZERO            67280000
         OI    IOB1,PRIVBIT        OPERATOR IS PRIVLEGED                67290000
         OI    IOB2,RECMM          MESSAGE-RECEIVING STATE              67300000
SVSOOK1  BAL   LINK,KSOHK          DEFUSE TIME BOMB                     67310000
         TM    IOB2,LOEXP          CHECK FOR EXPRESS TERMINAL           67320000
         BZ    SVSOOK3             THIS IS ORDINARY PORT                67330000
*                                                                  2224 67340000
*  IF THIS IS OPTERM, WE WANT TO IGNORE EXPRESS STATUS             2224 67350000
*                                                                  2224 67360000
         CL    PTR,OPTERM     IS THIS OPERATOR SIGNING ON?         2224 67370000
         BE    SVSOOK3          IF SO, DON'T SET FUSE              2224 67380000
         OI    IOB2,SHEXP          TURN ON AUTO BOUNCE BIT FOR IESZUG   67390000
         LM    2,3,KEXPLIM         ENQ IESZUG SO THAT USER WILL BE      67400000
         OR    2,PTR               BOUNCED AFTER FIXED TIME PERIOD      67410000
         BAL   5,ENQIE             UNLESS OPERATOR RESETS SHEXP BIT     67420000
SVSOOK3  LA    0,1                                                      67430000
         BAL   LINK,POSOM          INCREMENT SIGNED ON COUNT            67440000
         MVI   MAXRAT,INFIN        SVSOOK IS NOT RETRYABLE              67470000
         L     3,SOMPT             PRINT SIGN-ON MESSAGE                67480000
         CLI   1(3),16             CHECK FOR EMPTY MESSAGE              67490000
         BL    SVEXIT              SHORT MESSAGE IS IGNORED             67500000
         BAL   LINK,TYOSUB                                              67510000
         B     SVEXIT              TYOSUB HAS TWO RETURNS               67520000
         BAL   LINK,TYOINS                                              67530000
         B     STYO8               FIRE UP SUBCHANNEL SNEAKILY          67540000
SVSOOKCL CLI   HISNAME-PERLIB(1),0                                      67570000
         DROP  10                                                       67580000
*                                                                       67600000
SVTYOT   BALR  10,0                IN CASE WE GO TO STYONO              67610000
         USING SVTYO,10                                                 67620000
SVTYO    TM    ACTIVE,ATTENM       CHECK FOR UNRECOGNIZED ATTENTION     67630000
         BO    SVEXIT              IGNORE THIS TYO                      67640000
         LA    BA,PTIBUF           RELEASE INPUT BUFFERS MAYBE          67650000
         BAL   LINK,FREEBQ         IN CASE TYPEIN NEGLECTED TO DO SO.   67660000
         BAL   LINK,COPKILL        TERMINATE POSSIBLE COPY              67680000
         TM    IOB2,LVIDLEM        IGNORE TYO IF DS READY HAS DROPPED   67690000
         BO    SVEXIT                                                   67700000
         TM    IOB1,COPYWM         SPECIAL TREATMENT OF COPY SOURCE     67710000
         BO    COPTYO                                                   67720000
         BAL   LINK,TYORAT         COMPUTE BUFFER RATION                67770000
         L     3,REGSV             INTRP R0 IS BUFFER ADDRESS           67780000
         BAL   LINK,TYOSUB         EXPAND OVERSTRIKES, STORE IN BUFFERS 67790000
         B     STYONO              BUFFER RATION EXCEEDED               67800000
         BAL   LINK,TYOINS         LINK TO PREVIOUS LINES               67810000
STYO8    BAL   LINK,INITMWR        TRY TO START WRITE OPERATION         67890000
         B     SVEXIT                                                   67900000
*                                                                       67910000
*        SET EITHER OUTWAIT OR BUFFWAIT AND BACKUP OLDPSW SO TYO CAN    67920000
*        BE RETRYED.  STYONO ASSUMES SVC YYTYO IS PRECEDED BY A FOUR    67930000
*        BYTE INSTRUCTION.                                              67940000
*                                                                       67950000
STYONO   EQU   *                                                        67970000
*        DEBUGGING STATISTICS TO SEE IF WE HAVE ENOUGH BUFFERS          67980000
         L     HISTVAL,FREEBC      CURRENT FREE BUFFER COUNT            67990000
         LA    PHR,PERHFBC                                              68000000
         BAL   LINK,HISTCOMP                                            68010000
         LH    HISTVAL,PTBFA       BUFFERS CURRENTLY ALLOCATED, THIS TE 68020000
         LA    PHR,PERHBFA                                              68030000
         BAL   LINK,HISTCOMP                                            68040000
         B     SETBUFWQ                                                 68050000
*                                                                       68100000
COPTYO   L     2,COPSINK           TYO FROM COPY SOURCE                 68120000
         NI    ACTIVE-PERTERM(2),255-LOCKM   DESUSPEND SINK             68130000
         L     2,FREEBC            COMPUTE BUFFER RATION THIS TYO       68140000
         S     2,POSO              SUBTRACT 2 TIMES PLUS/SIGNEDON       68150000
         S     2,POSO                                                   68160000
         BNP   COPTYONO            NOT ENOUGH, QUIT                     68170000
         ST    2,MAXRAT                                            2222 68180000
         L     3,REGSV                                                  68190000
         BAL   LINK,TYOSUB         MOVE TO BUFFERS                      68200000
         B     COPTYONO            NOT ENOUGH BUFFERS                   68210000
         BAL   LINK,TYOINS         INSERT IN CHAIN                      68220000
         B     SVEXIT                                                   68230000
*        SOURCE BUFFER RATION REACHED                                   68240000
COPTYONO OI    ACTIVE,LOCKM        SUSPEND AND SIGNAL MORE OUTPUT       68250000
         L     2,COPSINK                                                68260000
         NI    ACTIVE-PERTERM(2),255-LOCKM                              68270000
         B     BACK6               Q END FOR SOURCE                     68280000
         DROP  10                                                       68300000
*                                                                       68310000
         USING SVTYI,10                                                 68320000
SVTYI    TM    IOB1,COPYRM+COPYWM                                       68340000
         BNZ   COPTYI              TYI FROM SOURCE OR SINK OF COPY      68350000
         TM    ACTIVE,ATTENM       SOME SPECIAL CASE                    68360000
         BNZ   SVTYI3              MAY BE ORDINARY ATTENTION OR PRESIGN 68370000
         TM    IOB2,BOUNCM         IGNORE TYI DURING BOUNCE OP          68430000
         BO    QUEND                                                    68440000
         OI    ACTIVE,INWAITM                                           68450000
         MVC   PTCPULIM(2),PTCPULM2 RESET CPU TIME LIMIT SINCE          68460000
*                                  INTRP HAS NOW RESPONDED.             68470000
         NI    SWITCHES,NOT-QZSW1 SET QZSW1 TO ZERO                C022 68480000
         B     SVTYI1              TRY TO START READ OP                 68490000
SVTYI3   TM    IOB1,NSIGNM         CHECK FOR SELDRZ1 CASE               68510000
         BZ    QUEND               IGNORE TYI UNLESS INIT SIGNON COMM   68520000
         MVI   ACTIVE,ATTENM+NONINM-ATTENM-NONINM  SET TO ZERO          68530000
         PTSET ACTIVE                                                   68540000
         NI    SWITCHES,NOT-QZSW1 SET QZSW1 TO ZERO                C022 68550000
         B     QUEND                                                    68560000
*                                                                       68580000
*        COPY SOURCE WS HAS ISSUED A TYI TO SIGNAL END OF COPY.         68600000
*        NOTE THAT THE SINK HAS NOT YET CONSUMED ALL COPY BUFFERS.      68610000
*        KILL SOURCE WS NOW.  COPY OPERATION WILL END WHEN SINK GETS    68620000
*        TO COPTYI3.                                                    68630000
COPTYI1  LR    4,PTR               WSLOSEC PARAM                        68640000
         BAL   LINK,WSLOSEC        DESTROY SOURCE WORKSPACE             68650000
         MVI   ACTIVE,INWAITM+MISCM   SUSPEND SOURCE WITHOUT LOCKM      68660000
         PTSET ACTIVE                                                   68670000
         L     2,COPSINK           SOURCE IS EXHAUSTED                  68680000
         NI    ACTIVE-PERTERM(2),255-LOCKM  ACTIVATE SINK               68690000
         B     QUEND               END OF SOURCE QUANTUM                68700000
*                                                                       68710000
COPTYI   TM    IOB1,COPYRM         TYI FROM SOURCE OR SINK              68720000
         BZ    COPTYI1             SOURCE                               68730000
         LA    BA,PTIBUF             RELEASE PREVIOUS INPUT LINE        68740000
         BAL   LINK,FREEBQ         IF IT EXISTS                         68750000
         L     2,COPSOUR           POINT TO SOURCE                      68760000
         L     BA,PTFBUF-PERTERM(2)  NEXT LINE FROM SOURCE              68770000
         ST    BA,PTIBUF                                                68780000
         MVI   PTFBUF+1-PERTERM(2),EMPTYM   ASSUME THIS IS LAST LINE    68790000
*        IF IT IS NOT, THE STORE BEFORE COPTYI6 WILL SET PTFUBF(SOURCE) 68800000
         SR    0,0                 TO COUNT BUFFERS                     68810000
         CLI   PTIBUF+1,EMPTYM     SOURCE HAS A LINE FOR SINK           68820000
         BNE   COPTYI4                                                  68830000
*        NO LINES AWAITING SINK                                         68840000
         NI    ACTIVE-PERTERM(2),255-LOCKM   DESUSPEND SOURCE           68850000
         BNZ   COPTYI3             END OF COPY, SOURCE HAS DONE TYI     68860000
         OI    ACTIVE,LOCKM        SUSPEND SINK                         68870000
         LH    0,=H'-2'            NOTE THAT PSW IS BACKED FOR TYI      68880000
         B     SVWAIT2             IN COPY MODE BUT NOT FOR NORMAL TYI  68890000
*                                                                       68900000
*        END OF COPY, SINK HAS ACCEPTED ALL INPUT                       68910000
COPTYI3  BAL   LINK,COPKILL        TERMINATE COPY                       68920000
         MVI   ACTIVE,ATTENM+NONINM SET ATTENTION SO TYPEIN WILL RETRY  68930000
         PTSET ACTIVE                                                   68940000
*        TYI, INCLUDING 6-SPACE INDENTATION.                            68950000
         B     QUEND                                                    68960000
         USING PERBUF,BA                                                68970000
COPTYI5  L     BA,PBTIC            UPDATE PTFBUF IN SOURCE              68980000
COPTYI4  OI    PBFLAG,FILLBIT      BY REMOVING ONE LINE                 68990000
         BCTR  0,0                 INCREMENT BUFFER COUNT               69000000
         TM    PBFLAG,LINEZ+LISTZ                                       69010000
         BZ    COPTYI5             CONTINUE TILL END OF LINE            69020000
         BO    COPTYI6             THIS IS LAST LINE IN LIST            69030000
         OI    PBFLAG,LISTZ        FOR FREEBUF                          69040000
         L     BA,PBTIC            BA POINTS TO NEXT LINE               69050000
         ST    BA,PTFBUF-PERTERM(2)   UPDATE FORNEXT COPTYI             69060000
COPTYI6  LH    1,PTBFA                                                  69070000
         SR    1,0                 INCREASE SINK BUFF COUNT             69080000
         STH   1,PTBFA                                                  69090000
         AH    0,PTBFA-PERTERM(2)  DECREASE SINK BUFFER COUNT           69100000
         STH   0,PTBFA-PERTERM(2)                                       69110000
         B     SVEXIT                                                   69120000
         DROP  BA                                                       69130000
         DROP  10                                                       69150000
*                                                                       69160000
         DROP  PTR,PXR             END OF SVC ROUTINES                  69170000
         DROP  MR                                                       69180000
         TITLE 'S P E C I A L   D I S K   R O U T I N E S'              69200000
*        LOSE SOURCE WORKSPACE (OF COPY) AT END OF A DISK OPERATION     69210000
*        COPKILL ACTIVATES SELWSK                                       69220000
         USING SELWSK,10                                                69230000
SELWSK   LM    1,3,CDDISK                                               69240000
         USING PERDISK,1                                                69250000
         USING PERCORE,3                                                69260000
         MVI   PCTERM+1,EMPTYM                                          69270000
         C     2,SDT               R2 = CDTERM                          69280000
         BE    SDKILLA             DIRECTORY READ TERMINATION           69290000
         MVI   PDTERM+1,EMPTYM                                          69300000
         BR    LINK                                                     69310000
         DROP  1,3,10                                                   69320000
*                                                                       69330000
*        SEE IF SECOND DIRECTORY MUST BE REWRITTEN                      69340000
         USING DIR3RD,10                                                69350000
DIR3RD   CLI   DIRCHANG,3          )SAVE OR )DROP IN PUB LIB MAY        69360000
         BNE   SETDROPZ            AFFECT TWO DIFFERENT DIRECTORIES     69370000
         DROP  10                                                       69380000
*              READ OTHER DIRECTORY                                     69390000
         MVI   CDOP,12             GO TO DIR4TH AT SELECTOR INTERRUPT   69400000
         L     3,SDT                                                    69410000
         L     5,DIRSMAN           MAN NUMBER GIVES DIRECTORY NUMBER    69420000
         B     RSDIR1                                                   69430000
*                                                                       69440000
*        AFTER READ OF SECOND DIRECTORY (DIR3RD)                        69450000
         USING DIR4TH,10                                                69460000
DIR4TH   BAL   6,RELOCT            WAS NOT DONE THROUGH NORMAL CHANNELS 69470000
         L     1,CCPAR1                                                 69480000
         USING M,1                                                      69490000
         L     2,MANSTAR                                                69500000
         LA    3,MANENTL                                                69510000
         L     4,DIRSMAN           LIB OF ORIGINAL SAVER           3591 69520000
DIR4A    L     5,M(2)                                                   69530000
         CR    4,5                                                      69540000
         BE    DIR4B                                                    69550000
         LTR   5,5                                                      69560000
         BM    SETDROPZ            UNUSUAL -- WSS EXIST BUT MAN DOESN'T 69570000
         BXH   2,3,DIR4A                                                69580000
DIR4B    AR    1,2                                                      69590000
         SR    2,2                 BXLE INDEX                      3591 69600000
         LA    3,2                 BXLE INCREMENT AND STOPPER      3591 69610000
DIR4C    LH    4,MANWSQ-PERLIB(2,1)                                3591 69620000
         AH    4,DIRSWSQ(2)        BUMP QUOTA OR ACTUAL            3591 69630000
         BNM   *+6                 DON'T ALLOW NEGATIVE QUOTA      3591 69640000
         SR    4,4                                                 3591 69650000
         STH   4,MANWSQ-PERLIB(2,1)     STORE NEW QUOTA OR ACTUAL  3591 69660000
         BXLE  2,3,DIR4C           BRANCH TO GET ACTUAL            3591 69670000
         MVI   DIRCHANG,1          PREVENT REENTRY TO DIR4 TH FROM 3RD  69680000
         B     WWZO1               WRITE THIS DIRECTORY                 69690000
         DROP  10,1                                                3591 69700000
*                                                                       69710000
         USING PERTERM,4          SAVE AND DROP BASE                    69720000
         USING PERCORE,5                                                69730000
*                                                                       69740000
*        SIGN OFF DIR SEARCH AUTO SAVE, ACCOUNTING UPDATE               69750000
         USING DSZOFF,10                                                69760000
DSZOFF   LM    4,5,SDT &HDCORE                                          69770000
         MVC   CCPAR1+1(3),PCADDR                                       69780000
         L     3,CCPAR1                                                 69790000
         L     2,REGSV-M(3)     R0 FROM SAVED WORKSPACE                 69800000
         USING M,PXR                                                    69810000
         MVC   0(16,2),REGSV+2*4  DELIVER ACCOUNTING INFORMATION        69820000
         LR    5,LINK              PRESERVE LINK FOR LATER USE          69830000
         L     HISTVAL,REGSV+4*4   CONNECT TIME FOR THIS SESSION        69840000
         LA    PHR,PERHCONN        HISTAGRAPH                           69850000
         BAL   LINK,HISTCOMP                                            69860000
         L     HISTVAL,REGSV+5*4   CPU TIME FOR THIS SESSION            69870000
         LA    PHR,PERHCPU         HISTAGRAPH                           69880000
         BAL   LINK,HISTCOMP                                            69890000
         L     1,KEXPLIM           PURGE EXPRESS TERM IE                69900000
         OR    1,4                                                      69910000
         BAL   LINK,PRGIE          WHICH MAY NOT BE ENQUED              69920000
         LH    0,KX24M+2           R0 = -1                              69930000
         BAL   LINK,POSOM          DECREMENT SIGNED ON COUNT            69940000
         LR    LINK,5              RESTORE LINK                         69950000
         DROP  PXR                                                      69960000
         B     WWZO1               REWRITE DIRECTORY                    69970000
         DROP  10                                                       69980000
*                                                                       69990000
*        END OF DIRECTORY SEARCH SAVE OPERATION                         70000000
*        ASSUME REACHED BY  BALR  LINK,10   = = = = = = = = = = = =     70010000
         USING DSZSAVE,10                                               70020000
DSZSAVE  CLI   DIRCHANG,2                                               70030000
         BE    DSZBAD              INVALID SAVE OPERATION               70040000
         L     0,LIBBASE                                                70050000
         AH    0,DSFILE                                                 70060000
         ST    0,CDCBASE                                                70070000
         MVI   CDOP,6              END OF WRITE TO LIBRARY IS HANDLED   70080000
*              LIKE DROP END OF DIRECTORY SEARCH                        70090000
         LM    4,5,SDT  & HDCORE                                        70100000
         MVC   CCPAR1+1(3),PCADDR   PRESERVE OLD LABEL                  70110000
         L     3,CCPAR1                                                 70120000
         USING M,3                                                      70130000
         MVC   WFLLIB(LWFLAB),OBUF-M(PXR)  NEW WS LABEL FROM DIRSEAR    70140000
         MVC   PHYCYL,DIRSRES      ADDRESS FROM DIRECTORY          DASD 70150000
         STM   4,5,CDTERM          BASE REGISTER TROUBLE PREVENT        70160000
         B     CDCOMPS             BRANCH TO DSZS1                      70170000
         DROP  10                                                       70180000
*        END OF WORKSPACE WRITE DURING SAVE                             70190000
         DROP  3                                                        70200000
         USING WWZSAVE,10                                               70210000
WWZSAVE  TM    DIRCHANG,1                                               70220000
         BZ    SETDROPZ            DIRECTORY IS UNCHANGED               70230000
         DROP  10                                                       70240000
*                                                                       70250000
*        END OF DIRECTORY SEARCH DROP                                   70260000
DSZDROP  TM    DIRCHANG,1          MUST BE ONE OR THREE                 70270000
         BZ    DSZBAD              INVALID DROP                         70280000
WWZO1    MVC   PHYCYL,DIRCYL       ADDRESS FROM DIRECTORY          DASD 70290000
         MVC   CDCBASE,LIBBASE     ALL DIRECTORIES ON FIRST FILE        70300000
         MVI   CDOP,14             WRITE SECOND COPY NEXT               70310000
         L     4,SDT                                                    70320000
         L     5,PTCORE            DIRECTORY CORE SLOT                  70330000
         STM   4,5,CDTERM                                               70340000
         B     CDCOMPS                                                  70350000
         DROP  4,5                SAVE & DROP BASE REGISTERS            70360000
SETDROPZ MVC   SDQZSW,=A(DROPZ)    ERASE DIRECTORY NEXT TIME THROUGH    70370000
*                                  SCHEDULER                            70380000
         B     RINGSUB             ENCOURAGE TRIP THROUGH SCHEDULER     70390000
*                                                                       70400000
*        WRITE SECOND COPY OF DIRECTORY                                 70410000
DIR2ND   MVC   PHYCYL,ALTCYL       ALTERNATE DIRECTORY             DASD 70420000
         MVI   CDOP,8              GO TO DIR3RD AT SELECTOR INTERRUPT   70430000
         B     CDCOMP2                                                  70440000
*                                                                       70450000
         USING PERTERM,3           LOAD AND COPY BASE REGISTERS         70460000
         USING PERCORE,4                                                70470000
*        END OF DIRECTORY SEARCH LOAD                                   70480000
*        ASSUME REACHED BY  BALR  LINK,10   = = = = = = = = = = = =     70490000
DSZLOAD  CLI   DIRCHANG,0                                               70500000
         BNE   DSZBAD              INVALID LOAD                         70510000
         LM    3,4,SDT  &HDCORE                                         70520000
         MVI   PCTERM+1,EMPTYM    OLD WORKSPACE                         70530000
         B     DSZCOP2-DSZLOAD(10)                                      70540000
*        END OF DIRECTORY SEARCH COPY OPERATION                         70550000
         USING DSZCOPY,10                                               70560000
DSZCOPY  CLI   DIRCHANG,0                                               70570000
         BNE   DSZBAD              INVALID COPY                         70580000
         LM    3,4,SDT  & HDCORE                                        70590000
         MVC   PCTERM+1(3),SDT+1                                        70600000
         ST    4,PTCORE            WORKSPACE IS RECONNECTED             70610000
         MVI   ACTIVE,LOCKM        SINK  (HIGH PRIORITY)                70620000
         PTSET ACTIVE                                                   70630000
         OI    IOB1,COPYRM        MARK THIS AS SINK OF COPY OPERATION   70640000
         L     3,COPSOUR                                                70650000
         MVC   ACTIVE(4),KDSZCOPY    SETUP ACTIVE,MISCB,IOB1,IOB2(SINK) 70660000
         PTSET ACTIVE                                                   70670000
         PTSET MISCB                                                    70680000
         PTSET IOB1                                                     70690000
         PTSET IOB2                                                     70700000
         DROP  10                  DSZLOAD BASE REG IS DIFFERENT        70710000
DSZCOP2  MVC   PHYCYL,DIRSRES      LIBRARY CYLINDER FOR DISK READ  DASD 70720000
         L     0,LIBBASE                                                70730000
         AH    0,DSFILE            GET PROPER DISK ADDRESS              70740000
         ST    0,CDCBASE                                                70750000
         MVI   PTCORE+1,EMPTYM                                          70760000
         L     4,CDCORE           DIRECTORY SLOT                        70770000
         MVI   PCTERM+1,EMPTYM                                          70780000
         MVC   CDCAD+1(3),PCADDR                                        70790000
         LA    2,CDTERM+PERDISK-PDTERM ADDR OF DUMMY PERDISK            70800000
         ST    LINK,DSZEXIT                                             70810000
         MVI   CDOP,10             RESET OURDISK UPON COMPLETION OF SEL 70820000
         BAL   LINK,RSELSTAR       SET MORE FLAGS AND SIO               70830000
         L     LINK,DSZEXIT                                             70840000
         B     SDKILL             TERMINATE SPECIAL DISK OPERATION      70850000
         DROP  3,4                 END OF LOAD COPY                     70860000
KDSZCOPY DC    AL1(0,0,COPYWM,0)                                        70870000
*                                                                       70890000
         TITLE 'I N T E R V A L  E V E N T S'                           70900000
         USING PERTERM,PTR                                              70910000
         USING MPXSAVE,MR                                               70920000
*        MR AND PTR ARE VALID FOR MOST INTERVAL EVENTS                  70930000
*                                                                       70940000
*                                                                       70950000
         USING IEMPX,10                                                 70960000
IEMPX    CLI   PTTYPE,0            IGNORE INTERVAL EVENT TO DUMMY       70970000
         BE    EXTIM2              PERTERM OR TO PUBENT                 70980000
         MVI   DELZFLG,1           FOR MPXEXIT                          70990000
         NI    STATE,255-QIEBIT    AVOID PURGE AT MSIOERR               71000000
         MVC   DELPSW+3(1),PTUNAD                                       71010000
         MVC   MXOLDPSW(16),DELPSW   DUMMY CSW AND EXIT ADDREESS        71020000
         LH    1,MPXCHANL          CHANNEL ADDRESS                 5991 71030000
         IC    1,PTUNAD                                                 71040000
         BAL   3,IODADV           RECORD SGDELZ                         71050000
         USING IODBUG,2                                                 71060000
         MVI   IODIE,X'FD'         INDICATE MPX IE                      71070000
         MVC   IODTYPE,PTTYPE      RECORD PTTYPE & STATE                71080000
         MVC   IODCCB,PUCCB        RECORD PUCCB                         71090000
         DROP  2                                                        71100000
         BAL   1,DEVXCC            PREPARE TO SKIP MSIOERR CODE         71110000
         LR    PXR,6                                                    71120000
         MVI   MSERR,0             PSEUDO INTERRUPT                     71130000
         LA    SIGR,SGDELZ                                              71140000
         B     ANALSIG                                                  71150000
*                                                                       71160000
         USING IECLOK,10                                                71170000
IECLOK   NI    MISCB,255-CLOKWAIT  DESUSPEND AFTER TIME INTERVAL        71180000
         BNZ   EXTIM2              MISCM IS OR/MISCB                    71190000
         MVI   RESCH,1             POST SCHEDULER                  C023 71200000
         NI    ACTIVE,255-MISCM                                         71210000
         B     EXTIM2                                                   71220000
*                                                                       71230000
*        SIGN OFF HOLD KILL                                             71250000
         USING IESOHK,10                                                71260000
IESOHK   CLI   STATE,DVBUSY+READS                                       71270000
         BNE   IESOH2              PROCRASTINATE HIO                    71280000
         MVI   PTFBUF+1,EMPTYM     AVOID RELEASE OF NONBUFFER           71290000
         MVI   STATE,DVBUSY+TODROP  DISABLE AT NEXT INTERRUPT           71300000
         LA    PTR,0(PTR)                                               71310000
         BAL   LINK,OFFSUB         KILL POSSIBLE WORKSPACE              71320000
         BAL   LINK,HIOSUB         HALT READ                            71330000
         B     EXTIM2                                                   71340000
*        EXTRA TWO SECONDS GRACE                                        71350000
IESOH2   LR    2,PTR                                                    71360000
         O     2,SVOFLIM           RE-ENQUEUE SIGNOFF HOLD KILL         71370000
         LA    3,TWOSEC                                                 71380000
         L     0,REALTIME                                               71390000
         BAL   5,ENQIET                                                 71400000
         B     EXTIM2                                                   71410000
         DROP  10                                                  3064 71420000
*                                                                       71630000
*        PANICINT HAS ELAPSED, SETPAN HAS NOT BEEN PURGED               71640000
         USING SETPAN,PTR                                               71650000
         SETPAN                                                         71660000
         DROP  PTR                                                      71670000
*                                                                       71680000
*        SET PANICINT TO PROTECT AGAINST A RUN-AWAY INTERPRETER         71690000
SETBELL0 BALR  PTR,0          ESTABLISH ADDRESSIBILITY FOR SETBELL 3064 71710000
         USING SETBELL,PTR                                         3064 71720000
SETBELL  LM    2,3,QUANLIM    QUANTUM LIMIT EVENT DATA             3064 71730000
*        QZACT SETPAN         GET CPU TIME USED                    3064 71740000
         QZACT SETPAN         GET CPU TIME USED                    3064 71750000
         SR    3,0            SUBTRACT FROM TIME REQUESTED         3064 71760000
         LA    3,MAXQUAN/6(,3) ADD AN EXTRA 15 PERCENT FOR SECON   3064 71770000
*                             AND SUBSEQUENT ATTEMPTS TO GET A     3064 71780000
         BP    SETBELL2       FULL QUANTUM                         3064 71790000
         DROP  PTR                                                 3064 71800000
SETBELL1 LM    2,3,PANLIM    PANIC LIMIT EVENT                     3064 71810000
SETBELL2 ST    2,QZPRG       SAVE EVENT TYPE FOR PRGIE AT QEND     3064 71820000
         L     0,REALTIME                                               71880000
         BAL   5,ENQIET       SETUP PANICINT                            71890000
         BAL   LINK,RINGSUB        TERMINATE QUANTUM                    71900000
         B     EXTIM2                                                   71910000
*                                                                       71920000
*                                                                       71930000
*        EXPLIM MINUTES AFTER SIGNON AT AN EXPRESS PORT.                71940000
*        BOUNCE HIM IF HE HAS NOT PAID THE SCHNELLZUG AUSLAG            71950000
         USING IESZUG,10                                                71960000
         USING PERTERM,PTR                                              71970000
IESZUG   LA    8,EXTIM2            RETURN ADDRESS FOR BOUNSUB           71980000
         TM    IOB2,SHEXP                                               72000000
         BCR   8,8                 HE HAS PAID THE AUSLAG               72010000
*        FALL INTO BOUNCE SUBROUTINE                                    72060000
*                                                                       72070000
*        BOUNCE SUBROUTINE                                              72080000
*        PTR IS TERMINAL TO BOUNCE                                      72090000
*        R8 IS RETURN                                                   72100000
*        R10 IS LOCAL BASE                                              72110000
BOUNSUB  BALR  10,0                                                     72120000
         USING *,10                                                     72130000
         TM    IOB1,NSIGNM         IGNORE IF NOT SIGNED ON              72150000
         BZ    BOUN1                                                    72160000
         TM    MISCB,NOWSM         ALLOW BOUNCE IF NSIGNM BUT NOT       72170000
         BCR   1,8                 IF TERM IS WITHOUT WS                72180000
BOUN1    EQU   *                                                        72190000
*                                  WE ASSUME A POSSIBLE COPY WILL       72200000
*                                  TERMINATE EVENTUALLY. A CALL TO      72210000
*                                  COPKILL IS NOT DESIRABLE HERE.       72220000
         OI    IOB2,BOUNCM         FORCE HIM OFF                        72240000
         C     PTR,SDT             DO NOTHING NOW IF THIS IS            72260000
         BCR   8,8                 THE SPECIAL DISK TERMINAL            72270000
         BAL   5,SHCPUSUB          SET CPU LIMIT TO ONE SECOND          72320000
         LR    1,PTR               ASSUME MPX EVENT ENQ'D               72330000
         TM    MISCB,CLOKWAIT      PURGE CLOKWAIT EVENT                 72340000
         BZ    *+8                 IF ENQ'D, ELSE PURGE MPX             72350000
         O     1,KIETCLOK                                               72360000
         BAL   LINK,PRGIE                                               72370000
         CLI   DESBYTE,0           MESSAGE TO LOG MAYBE                 72380000
         BE    BOUN2               LEAVE IN TRAWAIT                     72390000
BOUN4    MVC   ACTIVE(2),ZERO      CLEAR ATTENTION AND SUSPENSION BITS  72410000
         PTSET ACTIVE                                                   72460000
         PTSET MISCB                                                    72470000
BOUN2    EQU   *                                                        72480000
         CLI   STATE,WRITES+DVBUSY                                      72490000
         BCR   8,8  BER            ALLOW OUTPUT TO FINISH               72500000
         TM    STATE,SENREQ        TRUE IF STATE IS TRANSIENT           72510000
         BO    *+8                 SVSTAT IS ALREADY PERM STATE         72520000
         EX    0,HIDESTAT          SAVSTAT IS STATE                     72530000
         XI    SAVSTAT,READS                                            72540000
         TM    SAVSTAT,X'0F'       ALL ZERO IN READ STATE               72550000
         BNZ   *+8                 PTFBUF POINTS TO A BUFFER            72560000
         MVI   PTFBUF+1,EMPTYM     AVOID RELEASE OF NON-BUFFER          72570000
         TM    STATE,DVBUSY        SEE IF COMMAND IS PENDING            72580000
         MVI   STATE,IDLE          ASSUME NO                            72590000
         BCR   8,8  BER            NO COMMAND ERGO, NO HIO              72600000
         MVI   STATE,IDLE+DVBUSY                                        72610000
BOUN5    LR    LINK,8              HIOSUB EXIT IS BOUNSUB EXIT          72620000
         B     HIOSUB                                                   72630000
         DROP  10                                                       72640000
*                                                                       72650000
         SETHILO                                                        72670000
         ENTRY HILIM                                                    72680000
*                                                                       72690000
*        HILIM ENTRY IN TRANSFER VECTOR ALLOWS OPFNS ACCESS TO          72700000
*        PPERQ EXPLIM HILIM LOLIM                                       72710000
*        *** NOTE *** OPFNS MAKE ASSUMPTIONS ABOUT ORDERING ***         72720000
*        TIME LIMIT FOR EXPRESS (SCHNELLZUG) TERMINALS                  72730000
KEXPLIM  DC    A(IETSZUG*F*F*F,EXPLIM)                                  72740000
HILIM    IEBRN APLSETHI,MAXQUAN    LIMIT ON HIGH PRIORITY.              72750000
LOWTIME  EQU   HILIM+4                                                  72760000
LOWLIM   IEBRN APLSETLO,MINQUAN    LIMIT ON LOW PRIORITY.               72770000
HIGHTIME EQU   LOWLIM+4                                                 72780000
*                                                                       72800000
*                                                                       72810000
CONN     PHGEN 2178000,122,6       CONNECT TIME FOR THIS SESSION        72820000
*                                                                       72830000
CPU      PHGEN 14460,242,7         CPU TIME FOR THIS SESSION            72840000
*                                                                       72850000
         DROP  MR                                                       72860000
         TITLE 'MULTIPROGRAMMING APL TERMINATION.'                      72880000
*                                                                       73050000
*        THE OPERATOR HAS SIGNED OFF AFTER USING 'SHUTDOWN'             73060000
*                                                                       73070000
APLCNCL  BALR  9,0                                                      73080000
         USING *,9                                                      73090000
*                                                                       73110000
*        HALT ALL 270X LINES                                            73120000
*                                                                       73130000
         LM    0,2,PTBXLE                                               73140000
         USING PERTERM,2                                                73150000
CNCHIO   CLI   PTTYPE,0            IF DUMMY PERTERM, IGNORE             73160000
         BE    CNCHIO2                                                  73170000
         CLI   PTTYPE,Q1052        IF NOT 270X DEVICE, IGNORE LASO      73180000
         BNL   CNCHIO2                                                  73190000
         LH    1,MPXCHANL          AVOID HIO ON BURST MODE         5991 73200000
         TCH   0(3)                BECAUSE IT IS PROBABLY FOR ANOTHER   73210000
         BC    2,*-4               DEVICE                               73220000
         IC    3,PTUNAD                                                 73230000
CNCHIO1  MVI   CSW+4,0                                                  73240000
         HIO   0(3)                                                     73250000
         TM    CSW+4,CUB2702       270X REJECTED HIO                    73260000
         BO    CNCHIO1             HIT IT AGAIN                         73270000
CNCHIO2  BXLE  2,0,CNCHIO                                               73280000
         DROP  2                                                        73290000
*                                                                       73300000
*        SET STORAGE KEYS BACK THE WAY THE HOST SYSTEM HAD THEM         73310000
*                                                                       73320000
         L     6,CURRENTM          ACTIVE WORKSPACE, MAYBE.             73330000
         SR    3,3                                                      73340000
         IC    3,INACTKEY          HOST ASSIGNED PROTECT KEY.           73350000
         BAL   LINK,SSKSUB         RESET STORAGE KEYS.                  73360000
*                                                                   K03 74430000
*   IT IS TIME TO TERMINATE THE APL SUBTASK.                        K03 74440000
*        ARRANGE FOR DAUGHTER TO BE POSTED,                         K03 74450000
*        AT WHICH TIME THE SVC EXIT WILL BE EXECUTED.               K03 74460000
*                                                                   K03 74470000
         LA    1,OSEXIT            NEXT TIME THE DAUGHTER TASK IS  5996 74480000
         L     3,RBFILLE           DISPATCHED BY OS, GO TO         5996 74490000
         ST    1,RBOPSW+4(3)       THE TERMINATION CODE.           5996 74500000
         OI    RESCH,4        MAKE SURE SUBTASK GETS POSTED         K03 74510000
         B     EXRET                                                    74520000
         DROP  9                                                        74530000
*                                                                   K03 74540000
*   APL HAS TERMINATED, TELL MOTHER ALL ABOUT IT.                   K03 74550000
*                                                                   K03 74560000
OSEXIT   SR    15,15          RC=0 FOR NORMAL TERMINATION           K03 74570000
         SVC   EXIT                                                 K03 74580000
         SPACE 3                                                    K03 74590000
EXIT     EQU   3                                                    K03 74600000
         SPACE 1                                                        74630000
*        ROUTINE TO POST DAUGHTER TASK                                  74640000
         SPACE 1                                                        74650000
         USING MVTPOST,2                                                74660000
MVTPOST  TM    ECBFILLE,X'40' ALREADY POSTED ?                     C042 74670000
         BCR   7,1            YES, SO DON'T DO IT AGAIN            C042 74800000
         SPACE 1                                                        74890000
         STM   0,15,RPOSTSV                                             74900000
         SR    10,10              RETURN CODE.                          74910000
         LA    11,ECBFILLE         DAUGHTER'S ECB.                      74920000
         L     12,TCBFILLE         ADDRESS OF DAUGHTER'S TCB.           74930000
         L     15,CVT              ADDRESS OF THE CVT.                  74940000
         L     15,CVT0PT01(15)     BRANCH ENTRY TO POST.                74950000
         BALR  14,15                                                    74960000
         USING *,14                                                     74970000
         LM    0,15,RPOSTSV                                             74980000
         USING APLLOW,14                                                74990000
         BR    1                   RETURN.                              75000000
         SPACE 1                                                        75010000
RPOSTSV  DS    16F                                                      75020000
         SPACE 1                                                        75030000
         TITLE 'SELECTOR CHANNEL START IO AND ERROR RECOVERY ROUTINES'  75050000
*        SELECTOR CHANNEL START IO AND ERROR RECOVERY ROUTINES          75060000
         USING SELSTAR,10                                               75070000
         SELSTAR                                                        75080000
*                                                                       75090000
*                                                                       75100000
* SELECTOR CHANNEL DISK ERROR RETRY SUBROUTINE                          75110000
SELRTRY  LA    0,8                 LOCATE SEEK COMMAND                  75120000
         MVI   SELFERR,0           CLEAR CDCOMP FORCED ERROR MARK       75140000
         MVI   RD1A,0              CLEAR TIC/NOP BEFORE RETRY      2540 75150000
         MVC   SELSTAT,CSW+4       SAVE STATUS FOR SELERLOG        DASD 75160000
         L     1,CSW                                                    75170000
         LA    1,0(0,1)            REMOVE HIGH-ORDER GARBAGE            75180000
SELRTR1  SR    1,0                                                      75190000
         BM    DRA2                ADDRESS WAS ZERO, NO CCW CHAIN       75200000
         CLI   0(1),SEEK                                                75210000
         BNE   SELRTR1                                                  75220000
DRSIO2   EQU   *                   SA ONLY, ENTRY FROM SELSTAR          75230000
         L     2,0(1)              SEEK DATA ADDRESS                    75240000
         MVC   SELSENS+4(2),2(2)   CYLINDER                        DASD 75250000
         MVC   SELSENS+7(1),5(2)   HEAD                            DASD 75260000
         MVI   SEEKAD,0            POSSIBLE GARBAGE HERE, ALSO          75270000
         LA    0,1                                                      75280000
         AH    0,SELCNT            INCREMENT ERROR COUNT                75290000
         STH   0,SELCNT                                                 75300000
         C     1,SEEKAD            SAME AS PREVIOUS ERROR MAYBE         75310000
         BNE   DRA1                NEW ERROR                            75320000
         CLI   SELCNT+1,SELERMX    COMPARE WITH MAX NUMBER RETRIES      75330000
         BL    DRA2                                                     75340000
SELRTR2  EQU   *              ENTRY FROM SCHEDULER DETECTED FOR    DASD 75420000
*                             UNRECOVERABLE  I/O  ERROR            DASD 75430000
         TM    SWITCHES,SELAPENT   IF WE ENTERED THE APPENDAGE     DASD 75440000
         BO    SELOGIT             WE FILLED IN THE SELERLOG DATA  DASD 75450000
         LA    9,DSKIOB            LETS USE THE DSECT              DASD 75460000
         USING IOBD,9              TELL THE ASSEMBLER              DASD 75470000
         MVC   SELSTAT,IOBCSW+3    OTHERWISE WE SHOULD FILL IT IN  DASD 75480000
         MVC   SELSENS(2),IOBSENS0 FROM THE IOB                    DASD 75490000
         MVI   SELSENS+2,X'FF'     THIS MEANS THAT THERE ARE ONLY  DASD 75500000
*              TWO VALID SENSE BYTES AND THAT FOLLOWING            DASD 75510000
         MVC   SELSENS+3(1),IOBECBCC   THIS IS THE COMPLETION CODE DASD 75520000
         MVC   SELSENS+4(2),IOBSEEK+3  MOVE IN THE CYLINDER        DASD 75530000
         MVC   SELSENS+6(1),IOBSEEK+5  AND THE LAST H FOR CCH      DASD 75540000
         L     9,IOBDCB            GET THE ADDRESS OF THE DCB      DASD 75550000
         L     9,DCBDEB(9)         GET THE DEB ADDRESS             DASD 75560000
         L     9,DEBUCB(9)         GET UCB ADDRESS                 DASD 75570000
         MVC   SELUNIT,UCBCHA(9)   MOVE IN CUU                     DASD 75580000
         MVO   SELUNIT(1),CDOP     AND THE CURRENT OPERATION       DASD 75590000
SELOGIT  BAL   9,SELERLOG          LOG THE ERROR                   DASD 75610000
         CLI   DOP+1,X'06'                                              75620000
         UGH   NE                  PERMANENT WRITE ERROR                75630000
*                                                                       75640000
*        PERMANENT READ ERROR                                           75650000
         CLC   CDCBASE(4),LIBBASE  ARE DIRECTORIES IN THIS EXTENT?      75660000
         BNE   DRP30               NO. NONDISASTER                      75670000
         CLC   PHYCYL,ALTCYL       IF THIS IS THE ALTERNATE        DASD 75680000
         UGH   E                   THE DIRECTORY IS LOST           DASD 75690000
         CLC   PHYCYL,DIRCYL       DISASTER ONLY IF READING        DASD 75700000
         BNE   DRP30               A DIRECTORY                          75710000
*                                                                       75720000
*        DIRECTORY READ ERROR RECOVERY.                                 75730000
*                                                                  DASD 76010000
*        TRY TO READ SECOND COPY OF DIRECTORY                      DASD 76020000
*                                                                  DASD 76030000
         MVC   PHYCYL,ALTCYL       OTHERWISE TRY THE ALTERNATE     DASD 76040000
         B     DRP4                GO START READING                DASD 76050000
*        PERMANENT READ ERROR OF A WORKSPACE                            76070000
DRP30    MVI   SELBUSY,0           GIVE UP GRACEFULLY                   76080000
         MVI   CDCBASE+1,EMPTYM    FORCE PROG CK IF NOT SET BEFORE USE  76090000
         LH    1,COPLIM            MUST DECREASE ALLOWABLE NUMBER OF    76100000
         BCT   1,DRP6              COPIES AND LIBS IF THIS IS SWAP AREA 76110000
         UGH   ,                   UNRECOVERABLE DIRECTORY READ ERROR   76120000
*                                                                       76130000
DRP6     L     PTR,CDTERM          HAPLESS TERMINAL                     76140000
         CLI   CDOP,2              CHECK FOR SWAP AREA                  76150000
         BNE   LEMP                NOT A SWAPPING READ                  76160000
         STH   1,COPLIM            SWAPPING READ.  DROP COPLIM.         76170000
         L     1,CDDISK            MAKE SLOT UNUSABLE AND LOSE          76180000
         MVC   PDTERM+1-PERDISK(3,1),=AL3(DUMINACT)  UNREADABLE WS      76190000
         B     LEMP                ESTABLISH LOAD EMPTY                 76200000
*                                                                       76260000
DRA1     ST    1,SEEKAD                                                 76310000
DRA2     EQU   *                                                   DASD 76320000
*        MVT APPENDAGE - GET SENSE BYTES FROM UCB.                      76490000
         L     2,APLSAVE+4*7       UCB ADDRESS.                         76500000
         LH    1,UCBCHA(2)         PHYSICAL CHANNEL AND UNIT ADR   DASD 76510000
         N     1,=F'16383'        X'3FFF' OS USES THE TOP TWO BITS DASD 76520000
         MVC   SELSENS(4),UCBSNS(2)                                     76530000
         USING MPXSAVE,MR                                          DASD 76540000
         TM    UCBFL5(2),X'08'     ARE THESE THE SENSE BYTES       DASD 76550000
         BZ    DRSIO3              YES                             DASD 76560000
         L     3,UCBSNS+2(2)       IF NOT, USE INDIRECT ADDRESSING DASD 76570000
         MVC   SELSENS(4),0(3)     FOR THE SENSE BYTES             DASD 76580000
DRSIO3   BAL   3,IODADV                                                 76690000
         USING IODBUG,2                                                 76700000
         MVC   IODSENSE,SELSENS    ERROR RECORD                         76710000
         MVO   IODCDOP(1),CDOP     SAVE CURRENT OP                      76720000
         MVC   SELUNIT(2),IODCDOP  SAVE CDOP & CUU FOR LATER PRINTING   76730000
         DROP  2                                                        76740000
         TM    CSW+4,UC            UNIT CHECK ERROR                DASD 77010000
         BCR   1,LINK              MAKE IOS DO ERROR RECOVERY      DASD 77020000
*   NON- UC  ERROR                                                 DASD 77030000
         L     0,SEEKAD            ADDRESS OF LAST SEEK            DASD 77040000
         B     SELSTAR             RESTART IO OPERATION            DASD 77050000
*                                                                  DASD 77060000
*        LOG PERMANENT I/O ERRORS                                  DASD 77070000
*                                                                  DASD 77080000
*        ERROR REPORT FORMAT:                                      DASD 77090000
*              OCCU=____,STATUS=____,SENSE=________,CCH=______     DASD 77100000
*                                                                  DASD 77110000
SELERLOG EQU   *                                                   DASD 77120000
         STM   MR,9,SELERSAV            SAVE THE REGS                   77140000
         L     MR,SVBASE                AND ADDRESS MPX CODE            77150000
         UNPK  ERLGA2,SELSENS(5)       SENSE=________,                  77160000
         TR    ERLGA2,HEXTAB                                            77170000
         MVI   ERLGA2+L'ERLGA2-1,ZCOMMA                                 77180000
         UNPK  ERLGA6,SELSTAT(3)       STATUS=____,                DASD 77190000
         TR    ERLGA6,HEXTAB                                       DASD 77200000
         MVI   ERLGA6+L'ERLGA6-1,ZCOMMA                            DASD 77210000
         UNPK  ERLGA3(5),SELSENS+4(3)  CCH=______                  DASD 77220000
         UNPK  ERLGA3+4(3),SELSENS+7(2)                            DASD 77230000
         TR    ERLGA3,HEXTAB                                            77240000
         MVI   ERLGA3+L'ERLGA3-1,ZBLANK                            DASD 77250000
         UNPK  ERLGA4,SELUNIT(3)       OCUU=____,                       77260000
         TR    ERLGA4,HEXTAB                                            77270000
         MVI   ERLGA4+L'ERLGA4-1,ZCOMMA                                 77280000
         LA    3,ERLGA1                                                 77370000
         BAL   LINK,NUINS          INSERT NOTE FROM UNDERGROUND         77380000
         LM    MR,9,SELERSAV            RESTORE THE REGS                77390000
         MVI   SELCNT+1,0          ZERO SEL CHAN ERROR COUNTER          77400000
         BR    9                   RETURN                               77410000
SELSTAT  DC    H'0'              LAST ABNORMAL STATUS FOR SELERLOG DASD 77420000
SELERSAV DS    15F                      REGISTER SAVE AREA              77430000
         DROP  MR                                                       77440000
SELSENS  DC    F'0'                FOUR BYTES FOR SEL CHAN SENSE BYTES  77640000
         DC    X'0000FE00'         FOR IODTAB STORAGE                   77650000
SELCNT   DC    H'0'                SEL CHAN ERROR COUNT                 77700000
SELUNIT  DC    H'0'                OCUU OF LAST SEL CHAN ERROR          77710000
SEEKAD   DC    F'0'                ADDRESS OF LAST GOOD SEEK       DASD 77840000
         DROP  10                                                  DASD 77850000
ERLGX    DC    D'0',F'0'           TEMP SAVE AREA                       77880000
ERLGA1   DC    Y(ERLGAZ-*-3)                                            77890000
         DC    AL1(ZO,ZC,ZU,ZU,ZEQ)                                     77900000
ERLGA4   DC    CL5' '                                                   77910000
         DC    AL1(ZS,ZT,ZA,ZT,ZU,ZS,ZEQ)                          DASD 77920000
ERLGA6   DC    CL5' '                                              DASD 77930000
         DC    AL1(ZS,ZE,ZN,ZS,ZE,ZEQ)                                  77940000
ERLGA2   DC    CL9' '                                                   77950000
         DC    AL1(ZC,ZC,ZH,ZEQ)                                   DASD 77960000
ERLGA3   DC    CL7' '                                              DASD 77970000
         DC    AL1(ZCR,ZEOB)                                       DASD 78010000
ERLGAZ   EQU   *                                                        78020000
         TITLE 'UGH  CATASTROPHIC (BUT RECOGNIZED) SYSTEM FAILURE.' K01 78050000
*                                                                   K01 78060000
*        A CATASTROPHIC FAILURE CONDITION HAS BEEN RECOGNIZED       K01 78070000
*              THE CURRENT ENVIRONMENT ( REGISTERS AND LOW CORE )   K01 78080000
*              WILL BE SAVED , AND APL ABNORMALLY TERMINATED.       K01 78090000
*                                                                   K01 78100000
         DROP  14                                                   K01 78110000
         USING UGHS,MR        ADDRESSIBILITY ESTABLISHED AT UGH     K01 78120000
*                                                                   K01 78130000
*  AT CALL TO  UGH,  A BAL 14,UGH  WAS EXECUTED.  AT UGH, REG MR    K01 78140000
*        WAS SAVED AT  0(14), AND ADDRESSIBILITY TO UGHS ESTABLISHEDK01 78150000
*                                                                   K01 78160000
UGHS     NOP   REUGH                                                K01 78170000
         MVI   UGHS+1,X'F0'                                         K01 78180000
         NI    UGHQA+3,X'E0'  ALIGN ADDRESS FOR EASY DUMP READING   K01 78190000
         L     MR,UGHQA                                             K01 78200000
         DROP  MR                                                   K01 78210000
         XC    0(256,MR),0(MR)     AN ALL ZERO AREA TO MAKE IT      K01 78220000
         USING UGHAREA,MR          STAND OUT IN A DUMP              K01 78230000
UGHAREA  DSECT                                                      K01 78240000
UGHAREAG DS    8D             BLANK LINES                           K01 78250000
REGS     DS    16F                                                  K01 78260000
         DS    4D                                                  2217 78270000
FR0      DS    D                                                    K01 78280000
FR2      DS    D                                                    K01 78290000
FR4      DS    D                                                    K01 78300000
FR6      DS    D                                                    K01 78310000
         DS    8D                                                   K01 78320000
*                                                                   K01 78330000
LCOR     DS    XL256                                                K01 78340000
UGHAREAZ DS    0D                                                   K01 78350000
UGHAREAL EQU   UGHAREAZ-UGHAREAG                                    K01 78360000
APLSUP   CSECT                                                      K01 78370000
*                                                                   K01 78380000
         STM   0,15,REGS                                            K01 78390000
         STD   0,FR0                                                K01 78400000
         STD   2,FR2                                                K01 78410000
         STD   4,FR4                                                K01 78420000
         STD   6,FR6                                                K01 78430000
         MVC   LCOR(256),0                                          K01 78440000
         MVC   REGS+4*MR(4),0(14)                                   K01 78450000
         DROP  MR                                                   K01 78460000
REUGH    BALR  2,0                                                  SUG 78470000
         USING *,2                                                  SUG 78480000
         L     14,ADAPLLOW         ADDRESSABILITY FOR APLLOW.      2217 78500000
         USING APLLOW,14                                           2217 78510000
         L     1,ABCODE            ABEND CODE 1200,DUMP            2217 78520000
         TM    UGHSW,SVC+EXTERNAL  SVC OR EXTERNAL?                2217 78530000
         BZ    UGHMPX              NO.                             2217 78540000
*        NO RETURN HAS TO BE MADE SO ABEND HERE.                   2217 78550000
UGHABEND ABEND (1)                 ABEND 1200,DUMP                 2217 78560000
UGHMPX   TM    UGHSW,MPXIO+APPENDG IF IT'S NOT MPX OR APPENDG WE   2217 78570000
         BZ    UGHABEND            ARE LOST SO ABEND.              2217 78580000
         L     0,TCBFILLE          ABTERM FILLE.                   2217 78590000
         L     4,CVT                                               2217 78600000
         LR    7,14                SAVE REG 14 ACROSS ABTERM.      2217 78610000
         L     14,CVTBTERM(4)      ABTERM ADDRESS.                 2217 78620000
         BALR  14,14               ABTERM RETURNS ON REG 14.       2217 78630000
         LR    14,7                RESTORE REG 14.                 2217 78640000
         TM    UGHSW,MPXIO         MPX?                            2217 78650000
         BZ    UGHAPPN             NO. IT IS APPENDG.              2217 78660000
         L     5,CVTTCBP(4)        TCBNEW/OLD POINTER.             2217 78670000
         MVC   0(8,5),MXCVTTCB     RESTORE ORIGINAL NEW/OLD.       2217 78680000
         XC    CSW(8),CSW          CLEAR CSW.                      2217 78690000
         CLC   TCBMERE,MXCVTTCB+4  MERE CURRENT?                   2217 78700000
         BE    IOREJ               YES-GOTO TO DISPATCHER VIA IOS  2217 78710000
         CLC   TCBFILLE,MXCVTTCB+4 FILLE CURRENT?                  2217 78720000
         BNE   IOREJ               NO. RETURN TO INTERRUPTEE.      2217 78730000
* SINCE FILLE IS CURRENT, MOVE RBOPSW TO IOOLDPSW AND              2217 78740000
*  GO TO THE OS DISPATCHER VIA IOS.                                2217 78750000
         L     6,RBFILLE                                           2217 78760000
         MVC   IOOLDPSW,RBOPSW(6)  MOVE RBOPSW TO IOOLDPSW.        2217 78770000
         B     IOREJ               OFF TO IOS AND THE OS DISPATCHER2217 78780000
* REG 10 IS THE DISPLACEMENT USED FOR RETURN TO IOS. IT IS SET     2217 78790000
* TO +12 SO THAT WE ARE NOT POSTED AND THE RQE IS NOT RELEASED.    2217 78800000
*                                                                  2217 78810000
UGHAPPN  MVI   4*10+APLSAVE+3,12   BRANCH RETURN TO IOS.           2217 78820000
         LR    9,14           ADDRESSABILITY                       2217 78830000
         B     SELUGH              BACK TO IOS+12.                 2217 78840000
ABCODE   DS    0F                  ABEND 1200,DUMP                 2217 78850000
         DC    X'80'               DUMP                            2217 78860000
         DC    AL3(1200)           ABEND 1200                      2217 78870000
ADAPLLOW DC    A(APLLOW)                                           2217 79010000
         DROP  2,14                                                2217 79020000
UGHQA    DC    A(TYPEIN+31)        +31 IS ALIGNMENT FOR DUMP.      2217 79030000
         TITLE 'LITERALS, DSECTS, AND MISC TABLES             05/11/70' 79050000
*                                                                       79060000
         ORG   LTAR                PUT LITERALS UNDER BASE REG ZERO     79070000
         LTORG                                                          79080000
LTARY    EQU   *                   MUST BE LESS THAN OR EQ LTARZ        79090000
LTARX    DS    0XL(1+LTARZ-LTARY)  CONDITIONAL ERROR FLAG AND LENGTH    79100000
* IF PREVIOUS CARD HAS ERROR MESSAGE, INCREASE LTAR STORAGE             79110000
*                                                                       79120000
         ORG                                                            79130000
SOMBF    DS    H,130C              HI MESSAGE BUFFER                    79140000
BROADBF  DS    H,130C              PA MESSAGE BUFFER                    79150000
         ORG   SOMBF                                                    79160000
         DC    H'0'                SOMBF & BROADBF MUST BE ON HALF WORD 79170000
*                                                                       79180000
         SVINIT                                                         79190000
*                                                                       79200000
         ORG                                                            79210000
*                                                                       79220000
*                                                                       79230000
*        ONE COPY PER CORE SLOT                                         79240000
PERCORE  DSECT                                                          79250000
PCQUONT  DS    1H                QUONT COUNTER                          79270000
PCADDR   DS    AL3               STARTING ADDRESS OF THIS SLOT          79320000
PCTERM   EQU   *-1               PERTERM BASE REGISTER                  79330000
         DS    AL3               HIGH ORDER BIT ON MEANS UNASSIGNED     79340000
         DS    0D                                                       79350000
PERCOREL EQU   *-PERCORE                                                79360000
PERDISK  DSECT                     ONE PER DISK AREA                    79370000
PDDA     DS    F              CCHH - DASD CYLINDER, HEAD ADDRESS   DASD 79380000
PDXTENT  EQU   *              SWAP EXTENT INDEX (PSFILE FORMAT)    DASD 79390000
PDTERM   DS    X                                                        79400000
         DS    AL3 (PERTERM)       HIGH ORDER BIT MEANS UNASSIGNED      79410000
PERDISKL EQU   *-PERDISK                                                79420000
IEBLOCK  DSECT                INTERVAL TIMER EVENT QUE BLOCK            79430000
IEBASE   DS    A              DESCRIBES EVENT                           79440000
IELINK   DS    A              LINK TO NEXT IEBLOCK                      79450000
IETIME   DS    F              CLOCK TIME AT WHICH EVENT IS DESIRED      79460000
PERDEVXG CSECT                                                          79470000
*        TABLE OF DEVICE CHARACTERISTICS, ENTRIES FOLLOW PERDEVX LAYOUT 79480000
*        NOTE..  CODE AT END OF UNRZ DEPENDS ON VALUES OF Q2741,Q1050   79490000
         MPDVX TS41                TSS 2741                             79500000
         MPDVX 2741                                                     79510000
         MPDVX AMBIG                                                    79520000
         MPDVX 1050                                                     79530000
         MPDVX 1052                                                     79540000
         DC    20X'00'  DUMMY PERDEVXG ENTRY FOR AUX TERMINAL  BAM15    79550000
*        LOW ORDER BITS OF STATE BYTE                                   79560000
WRITES   EQU   0                                                        79570000
WIRS     EQU   1              WRITE INT REQ STATE                       79580000
LISTEN   EQU   2                   PREPARE COMMAND LOADED               79590000
IDLE     EQU   3                   NO COMMAND LOADED                    79600000
READS    EQU   4                                                        79610000
PROCR    EQU   5                   PROCRASTINATED SIO                   79620000
LIRS     EQU   7              LISTEN INT REQ STATE                      79630000
TODROP   EQU   8                   DROP LINE AT NEXT INTERRUPT          79640000
DIAGN    EQU   9                   DIAGNOSTIC STATE                     79650000
*        HIGH ORDER BITS OF STATE BYTE                                  79660000
DVBUSY   EQU   X'80'               COMMAND LOADED                       79670000
DEMISS   EQU   X'40'               SPECIAL BIT                          79680000
SENREQ   EQU   X'20'               WITH PROCR, SENSE IO REQUIRED        79690000
QIEBIT   EQU   X'10'               IE QUEUED FOR THIS PUB               79700000
SENSING  EQU   X'40'+PROCR+SENREQ  LAST SUCCESSFUL SIO ON THIS DEVICE   79710000
*              WAS SENSIO.  NOTE THAT THIS IS DIFFERENT FROM PROCR+SENR 79720000
*PROCR+SENREQ  INDICATES FAILURE AT SIO TIME OF SENSEIO ON THIS DEVICE. 79730000
*              THE SENSEIO WILL BE RETRYED ON DEVICEEND.                79740000
*        SIGNAL DEFINITIONS (PASSED TO ANALSIG VIA SIGR)                79750000
SGNE     EQU   0                   NORMAL END                           79760000
MAXSTAT  EQU   10                                                       79770000
SGINTR   EQU   MAXSTAT                                                  79780000
SGMIN    EQU   2*MAXSTAT           MINOR ERROR                          79790000
SGDELZ   EQU   3*MAXSTAT           END OF DELAY PERIOD                  79800000
SGTIME   EQU   4*MAXSTAT           HIO OR 2702 READ TIMEOUT             79810000
*        SENSE BYTE DEFINITIONS                                         79820000
COMREJ   EQU   X'80'                                                    79830000
INTREQ   EQU   X'40'                                                    79840000
BUSOUT   EQU   X'20'                                                    79850000
EQUIPC   EQU   X'10'                                                    79860000
DATAC    EQU   X'08'                                                    79870000
OVERRUN  EQU   X'04'                                                    79880000
LOSTDATA EQU   X'02'                                                    79890000
TIMEOUT  EQU   X'01'                                                    79900000
*                                                                       79910000
*        CHANNEL STATUS WORD -- STATUS BYTES                            79920000
*        CSW + 4 -- DEVICE STATUS                                       79930000
ATT      EQU   X'80'               ATTENTION                            79940000
SM       EQU   X'40'               STATUS MODIFIER                      79950000
CUE      EQU   X'20'               CONTROL UNIT END                     79960000
BSY      EQU   X'10'               BUSY                                 79970000
CE       EQU   X'08'               CHANNEL END                          79980000
DE       EQU   X'04'               DEVICE END                           79990000
UC       EQU   X'02'               UNIT CHECK                           80000000
UE       EQU   X'01'               UNIT EXCEPTION                       80010000
*        CSW + 5 -- CHANNEL STATUS                                      80020000
PCICSW   EQU   X'80'               PROGRAM-CONTROL INTERRUPTION         80030000
IL       EQU   X'40'               INCORRECT LENGTH                     80040000
PC       EQU   X'20'               PROGRAM CHECK                        80050000
PRC      EQU   X'10'               PROTECTION CHECK                     80060000
CDC      EQU   X'08'               CHANNEL DATA CHECK                   80070000
CCC      EQU   X'04'               CHANNEL CONTROL CHECK                80080000
ICC      EQU   X'02'               INTERFACE CONTROL CHECK              80090000
CHC      EQU   X'01'               CHAINING CHECK                       80100000
*                                                                       80110000
CUB2702  EQU   SM+CUE+BSY          CONTROL UNIT BUSY FOR 270X           80120000
*                                                                       80130000
Q103A    EQU   Q1050+1             DISABLE LOGIC                        80140000
SCHIDEQ  EQU   X'31'               SEARCH ID EQUAL                 5993 80150000
APLSUP   CSECT                                                          80160000
*                                                                       80170000
     TUSGEN                                                             80180000
TUSTAB  TUSGEN                                                          80190000
SE2741   EQU   SE1050                                                   80200000
SE2741X  EQU   SE1050X                                                  80210000
SETS41X  EQU   SE2741X             AVOID MPDVX BUG                      80220000
*                                                                       80230000
*                                                                       80240000
MXSSAG   DS    (SGTIME+8)AL1                                            80250000
         PRINT NOGEN                                                    80260000
*        SSA MACRO PRESETS MXSSAG TABLE                                 80270000
*        BODY OF SSA CAN BE CONSIDERED..                                80280000
*              MXSSAG(/ ARG(/1/) ., ARG(/2/) /) ..= ARG(/3/)            80290000
*        ONLY USE OF MXSSAG IS AT ANALSIG WHICH DOES..                  80300000
*              ANALSIG.. GOTO  MXSSAG(/ STATE ., SIGR /)                80310000
         SSA   PROCR,SGNE,UNPRO                                         80320000
         SSA   PROCR,SGMIN,UNPRO                                        80330000
         SSA   PROCR,SGINTR,UNPINT                                      80340000
         SSA   PROCR,SGDELZ,UNPRO                                       80350000
         SSA   PROCR,SGTIME,UNDIS                                       80360000
*        FOLLOWING PORTION IS FOR 270X WITH 1050,2741 OR LOCAL 1052     80370000
*        1050 SIGNAL, STATE, ACTION MAP                                 80380000
         SSA   WRITES,SGNE,UNWZ                                         80390000
         SSA   WRITES,SGINTR,SETWIRS                                    80400000
         SSA   WRITES,SGMIN,UNWCNT                                      80410000
         SSA   WRITES,SGDELZ,UNRWC                                      80420000
         SSA   WRITES,SGTIME,SETWIRS                                    80430000
         SSA   READS,SGNE,UNRZA                                         80440000
         SSA   READS,SGMIN,UNRRT                                        80450000
*  1050 ASSUMPTION:  EOT OF THE POLLING SEQUENCE WILL BE TREATED AS     80460000
*        NEGATIVE ANSWER TO EOB IF 1050 IS AWAITING ANSWER.             80470000
         SSA   READS,SGINTR,UNRINT                                      80480000
         SSA   READS,SGDELZ,UNRRT                                       80490000
         SSA   READS,SGTIME,UNRTIME                                     80500000
         SSA   WIRS,SGNE,SETIDLE                                        80510000
         SSA   WIRS,SGTIME,SETIDLE                                      80520000
         SSA   WIRS,SGINTR,SETLIRS                                      80530000
         SSA   WIRS,SGDELZ,UNHIO                                        80540000
         SSA   WIRS,SGMIN,SETIDLE                                       80550000
         SSA   LIRS,SGNE,SETIDLE                                        80560000
         SSA   LIRS,SGMIN,SETIDLE                                       80570000
         SSA   LIRS,SGINTR,UNLIRINT                                     80580000
         SSA   LIRS,SGDELZ,UNLIRDZ                                      80590000
         SSA   LIRS,SGTIME,SETIDLE                                      80600000
         SSA   LISTEN,SGNE,UN2741BF                                     80610000
         SSA   LISTEN,SGINTR,SETLIRSA                                   80620000
         SSA   LISTEN,SGTIME,SETIDLE                                    80630000
         SSA   LISTEN,SGDELZ,UNHIO                                      80640000
         SSA   LISTEN,SGMIN,SETIDLE                                     80650000
         SSA   IDLE,SGNE,SETIDLE                                        80660000
         SSA   IDLE,SGINTR,UNSAT   GLITCH FOR 1052 WHICH IS TERM ZERO   80670000
         SSA   IDLE,SGMIN,SETIDLE                                       80680000
         SSA   IDLE,SGDELZ,SETIDLE                                      80690000
         SSA   IDLE,SGTIME,SETIDLE                                      80700000
         SSA   TODROP,SGNE,UNKILL1                                      80710000
         SSA   TODROP,SGTIME,UNKILL1                                    80720000
         SSA   TODROP,SGMIN,UNKILL1                                     80730000
         SSA   TODROP,SGINTR,UNKILL1                                    80740000
         SSA   TODROP,SGDELZ,UNKILL1                                    80750000
         PRINT GEN                                                      80760000
*                                                                       80770000
*        TABLE GIVING DEVICE CHARACTERISTICS                            80780000
PERDEVX  DSECT                                                          80790000
PXSENC   DS    HL1               LENGTH OF SENSE TO STATE MAP           80800000
         DS    AL3               ORIGIN OF SENSE TO STATE MAP           80810000
PXUEAD   DS    A                   ADDRESS OF UNIT EXCEPTION ROUTINE    80820000
PXMXR    DS    A(MXRCCC)  ROUTINE TO SETUP READ CCW CHAIN               80830000
PXRSTA   EQU   0+PXMXR             RESEND TEXT POINTER                  80840000
TYOTAD   DS    A(TYOTAB)           OUTPUT CONVERSION TABLES             80850000
TYITAD   DS    A(TYITAB)           INPUT CONVERSION TABLE               80860000
TYITAB   DSECT                                                          80870000
TYOTAB   DSECT                     DEVICE DEPENDENT TRANSLATE TABLES    80880000
TYOTAA   DS    CL(ZLENGTH)        MAIN TRANSLATE TABLE                  80890000
TYOTAT   DS    CL(ZLENGTH)        TRT FOR BACKSPACE INSERTION           80910000
*        TRANSFER VECTOR ALLOWS APL FUNCTIONS TO LOCATE ABS             80930000
*        ADDRESSIS IN APLSUP FOR DISPLAY AND PATCH PURPOSES             80940000
*        ALL CALLS OF THE PHGEN MACRO MUST PRECEED THIS POINT           80960000
HDIR     CSECT ,                   HISTOGRAM DIRECTORY                  80970000
         ORG   HBASE+8*5           TRANXFER VECTOR IS IBEAM 5           80980000
         DC    A(TVEC)             ADDRESS OF TRANSFER VECTOR           80990000
         DC    A(TVECZ-TVEC)       LENGTH OF TRANSFER VECTOR            81000000
         ORG   ,                   TRANSFER VECTOR IS IN HDIR           81010000
*                                  AFTER THE DIRECTORY                  81020000
HDIRZ    EQU   *                   END OF HISTOGRAM DIRECTORY           81030000
TVEC     EQU   *                   TVEC ENTRIES FOLLOW IN ORDER         81040000
* ***    WARNING OPFNS MAKES ASSUMPTIONS ABOUT THE ORDERING AND         81050000
* ***    PRESENCE OF ENTRIES IN THIS TABLE                              81060000
         DC    A(MPXCUTAB)                                              81070000
         DC    A(PUBENTL)                                               81080000
         DC    A(PUBENTG)                                               81090000
         DC    A(HILIM)                                                 81100000
         DC    A(PERDEVXG)                                              81110000
         DC    A(PTBXLE)                                                81120000
         DC    A(TYO1052)                                               81130000
         DC    A(CDCBXLE)                                               81140000
         DC    A(SOMBF)                                                 81150000
         DC    A(MONADTAB)                                              81160000
         DC    A(DYADTAB)                                               81170000
         DC    A(QUANLIM)                                               81180000
         DC    A(IODSIFT)                                               81190000
         DC    A(PCSWITCH)                                              81200000
         EXTRN APLXREF                                                  81210000
         DC    A(APLXREF)                                               81220000
TVECZ    EQU   *                   TVEC ENTRIES PRECEED IN ORDER        81230000
         EXTRN PUBENTG,CDCBXLE,MONADTAB,DYADTAB                         81240000
         EXTRN PCSWITCH                                                 81250000
         COPY  CDCPARS                                                  81270000
         COPY  TQE                                                      81290000
*                                                                       81310000
         END                                                            82240000
./  ADD    NAME=APLSATCH
ATCH     TITLE 'A T T A C H   O P E R A T O R S               05/11/70' 00180000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00360000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00540000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00720000
         PRINT OFF       APLDEFN, OPSECT                                01080000
EXCATEN  CSECT                                                          01260000
         COPY  APLDEFN                                                  01440000
         COPY  OPSECT                                                   01620000
         PRINT ON,NOGEN                                                 01800000
         TITLE 'A T T A C H   O P E R A T O R S               05/11/70' 01980000
         EXTRN OPSPACE                                                  02160000
         EXTRN ERROR                                                    02340000
         EXTRN FETCH                                                    02520000
EXCATEN  CSECT                                                          02700000
         USING *,9                                                      02880000
         USING OPSECT-16,13                                             03060000
         ST    12,CALLBASE         SAVE THE CALLING ROUTINES BASE REG   03240000
         DROP  9                                                        03420000
         BALR  12,0                                                     03600000
         USING *,12                                                     03780000
         ST    LKR,RETURN          SAVE RETURN ADDRESS                  03960000
         LA    14,(LEND-LORG+7)/8*8(14)                                 04140000
         LA    6,1                                                      04320000
         L     1,LHXRHO            GET NO OF ELE IN LEFT                04500000
         LTR   1,1                                                      04680000
         BP    EM1                 ITS NOT EMPTY                        04860000
         ST    6,LHTYPE            FORCE EMPTY TO BOOLEAN               05040000
         MVC   RCTYPE+3(1),RHTYPE+3      IN CASE WE FETCH               05220000
EM1      L     1,RHXRHO                                                 05400000
         LTR   1,1                 DO SAME FOR RIGHT SIDE               05580000
         BP    EM2                                                      05760000
         ST    6,RHTYPE            FORCE EMPTY TO BOOLEAN               05940000
         MVC   LCTYPE+3(1),LHTYPE+3  IN CASE WE FETCH                   06120000
EM2      L     1,RHTYPE            IF TYPES ARE THE SAME                06300000
         ST    1,RSTYPE            MAKE RESULT TYPE MAX                 06480000
         C     1,LHTYPE            OF ARG TYPES                         06660000
         BH    EX2                                                      06840000
         MVC   RSTYPE(4),LHTYPE   RESULT SAME TYPE AS LEFT              07020000
*              R15 = 4   TILL CALL OPSPACE                              07200000
*              R10 = ABSOLUTE ADDRESS OF RHOB IN STACK                  07380000
*              R8 =  ABSOLUTE ADDRESS OF RHOA IN STACK                  07560000
*              R7 =  ABSOLUTE ADDRESS OF RHOR IN STACK                  07740000
*              R6 =  RANK OF A                                          07920000
*              R5 = RANK B (TILL CATLAM)                                08100000
*              R3 =  INDEX                                              08280000
EX2      LA    15,4                                                     08460000
         L     6,LHRANK            4*RANK A                             08640000
         L     5,RHRANK            4*RANK B                             08820000
         ST    6,RRANK             RESULT RANK = RANK A                 09000000
*                                  GET MAXIMUM OF RANKS                 09180000
         LR    4,5                 ASSUME RANK B BIGGER                 09360000
         CR    5,6                 IS IT ?                              09540000
         BNL   *+6                 YES                                  09720000
         LR    4,6                 NO. A IS BIGGER                      09900000
*                                  R4=MAXIMUM OF RANKS                  10080000
         LA    10,DIM+4            ABSOLUTE ADDRESS OF RHOB             10260000
         LA    8,8(10,4)           ROOM FOR LARGEST RANK+2 WORD SLOP    10440000
*                                  ABSOLUTE ADDRESS OF RHOA             10620000
         LA    7,8(8,4)            LIKEWISE                             10800000
         LA    3,8(7,4)            END OF DIMENSION VECTORS        3067 10980000
         CR    3,TLR               CHECK OVERFLOW OF DIM TABLE     3067 11160000
         LA    1,ENONCE                                            3067 11340000
         BNL   ER                  NONCE ERROR IF OVERFLOW         3067 11520000
         LTR   5,5                 RANK B = ZERO THEN NOTHING TO MOVE   11700000
         BZ    MRHOA                                                    11880000
         L     3,RHBASE            M-ENTRY BASE OF B                    12060000
         LA    3,MRHO(3)           ABSOLUTE RHOB                        12240000
*              BECAUSE OF SLACK ITS OK TO MOVE AN EXTRA BYTE            12420000
         EX    5,MOVRHOB           MOVE RHOB INTO STACK                 12600000
MRHOA    LTR   6,6                 0=RANK A THEN NOTHING TO MOVE        12780000
         BZ    GINDEX                                                   12960000
         L     3,LHBASE                                                 13140000
         LA    3,MRHO(3)           ABSOLUTE RHOA                        13320000
         EX    6,MOVRHOA           MOVE RHOA INTO STACK                 13500000
         EX    6,MOVATOR           MOVE RHOR INTO STACK (COPY RHOA)     13680000
GINDEX   TM    INDBASE,X'C0'       IS AN INDEX SUPPLIED ?               13860000
         BNZ   GIN1                YES                                  14040000
         LR    3,4                 DEFAULT TO LARGEST RANK              14220000
         SR    3,15                ADJUST FOR ORIGIN                    14400000
         B     JINRANK1                                                 14580000
         SPACE 3                                                        14760000
GIN1     BO    FLTIND              BRANCH ON FRACTIONAL INDEX           14940000
         L     3,INDEX             GET INTEGER INDEX                    15120000
         B     JINRANK             CHECK RANGE OF INDEX                 15300000
         SPACE 3                                                        15480000
FLTIND   MVC   DBL,FINDEX          WE KNOW INDEX IS NOT WITHIN FUZZ     15660000
         LD    0,DBL               OF AN INTEGER SO WE CAN JUST ADD     15840000
         AD    0,DONE              ONE AND TAKE THE FLOOR               16020000
*                                  AND PRETEND ITS AN INTEGER           16200000
         LTER  0,0                 NO USE WASTING TIME ON               16380000
         BL    OUT                 A NEGATIVE INDEX                     16560000
         CE    0,TWO31             ALSO QUIT IF WAY TO BIG              16740000
         BNL   OUT                                                      16920000
         AW    0,RDUNZ             SHIFT OVER INTEGER PART              17100000
         STD   0,DBL                                                    17280000
         L     3,DBL+4             NOW WE HAVE IT AS AN INTEGER         17460000
         AR    4,15                PRETEND MAX RANK IS ONE LARGER       17640000
*                                  SO AN INDEX REQUESTING LAMINATE ON   17820000
*                                  THE RIGHT IS STILL IN RANGE          18000000
         SPACE 3                                                        18180000
JINRANK  SLA   3,2                 USE 4* INDEX                         18360000
JINRANK1 LA    0,1                 CONSTANT TO INSERT IN DIMENSIONS     18540000
         ST    0,AID               A INDEXED DIMENSION FOR LAMINATE     18720000
         ST    0,BID               B INDEXED DIMENSION FOR LAMINATE     18900000
         LTR   4,4                 BOTH SCALARS ?                       19080000
         BNZ   JDS                 NO SO CHECK INDEX                    19260000
         TM    INDBASE,X'C0'       YES THEN ITS LAMINATE 2F NO INDEX    19440000
         BZ    CAT8                DO LAMINATE                          19620000
*                                  IF FALL THROUGH THEN E[ROR           19800000
*                                  WILL BE CAUGHT BELOW BECAUSE         19980000
*                                  NO INDEX IS POSITIVE AN: LESS        20160000
*                                  THAN THE RANK OF A SCALAR            20340000
JDS      CR    3,4                 EQUALITY MEANS OUT OF RANGE          20520000
*                                  BECAUSE OF 0-ORIGIN INDEX            20700000
         BNL   OUT                 INDEX IS TOO BIG                     20880000
         LTR   3,3                 NEGATIVE MEANS TOO SMALL             21060000
         BL    OUT                                                      21240000
DIFFER   TM    INDBASE,X'C0'       IF FRACTIONAL INDEX                  21420000
         BO    LAM                 ITS LAMINATE                         21600000
         CR    5,6                 ELSE, IF EQUAL RANKS                 21780000
         BE    CATLAM                    ITS CATENATE                   21960000
         SPACE 6                                                        22140000
*                                  CAN ONLY BE ADJOIN                   22320000
*              IF EITHER A OR B IS SCALAR THEN WE EXTEND THE SCALAR TO  22500000
*              HAVE THE SAME DIMENSIONS AS THE OTHER ARG EXCEPT A       22680000
*              1 IN THE INDEXED POSITION                                22860000
         LTR   6,6                 IS A SCALAR ?                        23040000
         BNZ   BSC                 NO ITS NOT                           23220000
         EX    5,MOVBTOA           MOVE RHOB TO RHOA                    23400000
         LR    6,5                 SET RANK A TO RANK B                 23580000
         ST    0,0(3,8)            SET 1 IN INDEXED POSITION            23760000
         B     D3                                                       23940000
         SPACE                                                          24120000
BSC      LTR   5,5                 IS B SCALAR?                         24300000
         BNZ   NOSC                NO SCALAR EXTENSION                  24480000
         EX    6,MOVATOB           MOVE RHOA TO RHOB                    24660000
         LR    5,6                 SET RANK B TO RANK A                 24840000
         ST    0,0(3,10)           SET A 1 IN INDEXED POSITION          25020000
         B     CATLAM                                                   25200000
         SPACE 5                                                        25380000
*              WE HAVE ADJOIN OR NOTHING                                25560000
NOSC     LR    2,6                 RANK A                               25740000
         SR    2,5                 RANKA - RANK B                       25920000
         CR    2,15                DOES A HAVE BIGGER RANK?             26100000
         BE    D4                  YES                                  26280000
         CH    2,=H'-4'            DOES B HAVE BIGGER RANK              26460000
         BNE   RANER               RANKS MUST DIFFER BY EXACTLY ONE     26640000
*                                  WE INSERT A 1                        26820000
         LR    9,8                 INTO RHOA                            27000000
         BAL   1,INSERT                                                 27180000
D2       SR    8,15                NOW A STARTS ONE LOWER               27360000
         SR    7,15                PUT A INTO RESULT                    27540000
         LA    6,4(6)              NEW RANK OF A                        27720000
D3       EX    6,MOVATOR           OK TO MOVE ONE BYTE TO MUCH          27900000
         ST    6,RRANK             IS ALSO RANK OF B                    28080000
         B     CATLAM                                                   28260000
*                                  A HAS BIGGER RANK                    28440000
D4       LR    9,10                WE INSERT A 1 INTO RHOB              28620000
         BAL   1,INSERT                                                 28800000
         SR    10,15               NEW START OF RHOB                    28980000
*        AR    5,15                UP RANK B BY ONE (NEVER NEEDED)      29160000
         SPACE 8                                                        29340000
CATLAM   LTR   4,4                 IF SCALARS CAN ONLY BE LAMINATE      29520000
         BZ    CAT8                ITS LAMINATE OF SCALARS              29700000
CAT1     BCTR  6,0                 READY TO COMPARE DIMENSIONS          29880000
         LA    1,ELENGTH                                                30060000
         L     5,0(10,3)           R5 = RHOB(J)                         30240000
         L     2,0(8,3)            R2 = RHOA(J)                         30420000
         ST    1,0(10,3)           MAKE RHOB(J) = RHOA(J)               30600000
         ST    1,0(8,3)            TO MAKE COMPARISON EASY              30780000
         EX    6,CDIM              EQUAL WHERE REQUIRED ?               30960000
         BNE   ER                  NO                                   31140000
         ST    5,BID               SAVE B INDEXED POSITION              31320000
         ST    2,AID               SAVE A INDEXED POSITION              31500000
         AR    5,2                 ADD INDEXED DIMENSIONS               31680000
         ST    5,0(7,3)            SET RHOR(J)=RHOA(J)+RHOB(J)          31860000
         B     CALC                                                     32040000
         SPACE 8                                                        32220000
*                                  THIS IS A LAMINATE                   32400000
LAM      LTR   6,6                 IS A SCALAR                          32580000
         BNZ   BSCL                NO ITS NOT                           32760000
         EX    5,MOVBTOA           MOVE RHOB TO RHOA                    32940000
         EX    5,MOVATOR           MOVE IT INTO RESULT DIMENSION        33120000
         ST    5,RRANK             SET RESULT RANK                      33300000
         LR    6,5                 SET RANK A = RANK B                  33480000
BSCL     BCTR  6,0                 COMPARE LENGTH CODE                  33660000
         LTR   5,5                 IS B SCALAR                          33840000
         BZ    CAT8                YES SO SKIP COMPARE                  34020000
CAT6     SR    5,6                 RANKS MUST BE EQUAL                  34200000
         BCT   5,RANER             RECALL RANK A IS REDUCED FOR COMPARE 34380000
         EX    6,CDIM              ALL DIMENSIONS MUST BE EQUAL         34560000
         LA    1,ELENGTH                                                34740000
         BNE   ER                  LENGTH ERROR IF NOT                  34920000
*              ENTER HERE ON LAMINATE OF SCALARS BECAUSE                35100000
*              DIMENSIONS ARE AUTOMATICALLY EQUAL                       35280000
CAT8     LR    9,8                 INSERT A 1 TO LEFT OF INDEXED DIM    35460000
         BAL   1,INSERT            DONT REALLY CARE WHAT IS INSERTED    35640000
         SR    8,15                NEW START RHOA                       35820000
         AR    6,15                PRETEND ARG IS ONE HIGHR RANK        36000000
         LR    9,7                 WORK ON RESULT                       36180000
         LA    0,2                 PUT A 2 TO LEFT OF                   36360000
         BAL   1,INSERT            INDEXED DIMENSION                    36540000
         SR    7,15                NEW START OF RHOR                    36720000
         L     1,RRANK             UP RESULT RANK                       36900000
         AR    1,15                                                     37080000
         ST    1,RRANK                                                  37260000
*              I KNOW DIMENSIONS ARE THE SAME EXCEPT POSSIBLY AT        37440000
*              THE INDEXED POSITION                                     37620000
CALC     SR    4,4                 INDEX TO DIMENSION                   37800000
         SR    8,15                POINTS 1(4BYTES) BELOW RHOA          37980000
         LR    2,15                INCREMENT OF 4                       38160000
*                                  R3 ALREADY HAS THE INDEX             38340000
         LA    1,1                 PRIME THE PRODUCT                    38520000
         B     CAL2                                                     38700000
CAL1     M     0,0(4,8)            MULTIPLY IN NEXT DIMENSION           38880000
CAL2     BXLE  4,2,CAL1            AND AGAIN                            39060000
         ST    1,N                 = NUMBER OF TIMES TO LOOP            39240000
         LR    5,3                 SAVE INDEX                           39420000
         LA    3,1(6)              RANK OF A                            39600000
         LA    1,1                 PRIME THE PRODUCT                    39780000
         B     CAL4                                                     39960000
CAL3     M     0,0(4,8)            MULTIPLY IN NEXT DIMENSION           40140000
CAL4     BXLE  4,2,CAL3                                                 40320000
         L     3,AID               A INDEXED POSITION                   40500000
         MR    2,1                 GET MA = AMOUNT OF A TO MOVE AT ONC  40680000
         ST    3,MA                AND SAVE IT                          40860000
         M     0,BID               GET MB=AMOUNT OF B TO MOVE AT ONCE   41040000
         ST    1,MB                AND SAVE IT                          41220000
         A     1,MA                MA+MB                                41400000
         M     0,N                 RXRHO=N*(MA+MB)                      41580000
         MVC   DIM(256),0(7)       MOVE RESULT DIM DOWN SO OPSPACE      41760000
*        ST    1,RXRHO             SAVE IT (MAYBE NO NEED TO )          41940000
         LTR   1,1                 IF RESULT IS EMPTY                   42120000
         BNZ   TYPEOK              MAKE TYPE SAME AS RT ARG             42300000
         L     3,RHBASE            PICK UP TYPE FROM M-ENTRY BECAUSE    42480000
         LA    3,M(3)              RHTYPE FOR AN EMPTY ARRAY IS         42660000
         MVC   RSTYPE+3(1),MTYPE-M(3)                                   42840000
TYPEOK   L     3,RSTYPE                                                 43020000
         L     2,RRANK              DON'T FORGET THIS                   43200000
         L     10,=A(OPSPACE)                                           43380000
         BALR  LKR,10                                                   43560000
         L     2,RSTYPE                                                 43740000
         STC   2,MTYPE(1)          INSERT TYPE                          43920000
         L     2,RRANK                                                  44100000
         STH   2,MRANK(1)          AND RANK                             44280000
         LA    1,MRHO(1)           AT DIMENSION ABSOLUTE                44460000
         BCTR  2,0                                                      44640000
         EX    2,MTORES            MOVE RESULT DIM INTO M-ENTRY         44820000
         LA    1,1(2,1)            AT RESULT DATA ABSOLUTE              45000000
         ST 1,RESORG               SAVE IT ABSOLUTE (NOT USED OVER QUEN 45180000
*              ADJUST CONSTANTS AND PREPARE FOR LOOP                    45360000
*                                  LOOK AT LEFT ARG                     45540000
         L     3,MA                                                     45720000
         L     8,LHBASE                                                 45900000
         L     9,LCTYPE           FETCH CODE IN CASE OF CONVERSION      46080000
         BAL   4,ADJUST                                                 46260000
         C     6,BEXTEND           IF EXTEND IS USED                    46440000
         BNE   AB1                 USE LEFT ENTRY POINT                 46620000
         L     6,BEXTENDL                                               46800000
         MVC   CONVERTA(12),CONVERTS                                    46980000
AB1      ST    6,MOVEA             BRANCH ADDRESS                       47160000
         ST    8,AAD               STARTING DATA ADDRESS                47340000
         MR    6,3                 ADJUST MA FOR                        47520000
         ST    7,MA                LENGTH OF AN ITEM                    47700000
*                                  REPEAT FOR RIGHT ARG                 47880000
         L     3,MB                                                     48060000
         L     8,RHBASE                                                 48240000
         L     9,RCTYPE            FETCH CODE IN CASE OF CONVERSION     48420000
         BAL   4,ADJUST                                                 48600000
AB3      ST    6,MOVEB             STORE BRANCH ADDRESS                 48780000
         ST    8,BAD               AND STARTING ADDRESS                 48960000
         M     6,MB                ADJUST MB FOR LENGTH OF AN ITEM      49140000
         ST    7,MB                                                     49320000
         L     5,RSTYPE                                                 49500000
         L     6,RESORG            AN ABSOLUTE ADDRESS                  49680000
         SR    6,MR           MAKE IT RELATIVE                          49860000
         CH    5,=H'1'             IS RESULT BOOLEAN                    50040000
         BNE   AB15                                                     50220000
         SLL   6,3                 MAKE ROOM FOR BIT DISPLACE,ENT       50400000
AB15     L     9,N                 NUMBER OF TIMES TO LOOP              50580000
         LTR   9,9                 MIGHT NOT NEED TO LOOP AT ALL        50760000
         BNP   LP2                 COULD CHECK EARLIER BUT WHO CARES    50940000
         IC    5,LEN-1(5)          GET LENGHT OF RESULT                 51120000
         ST    5,CONVERTL+8        SAVE IT                              51300000
         ST    5,CONVERTS+8                                             51480000
         ST    5,CONVERTA+8                                             51660000
         L     10,BAD              MIGHT AS WELL USE REG 10             51840000
         SPACE 8                                                        52020000
LOOP     L     2,AAD               M-REL ADDRESS OR ELE INDEX OF A      52200000
         L     8,MA                # BYTES OR ELE TO MOVE               52380000
         EX    0,MOVEA                                                  52560000
         ST    2,AAD               SAVE A POINTER                       52740000
         LR    2,10                M-REL ADDRESS OR ELE INDEX OF NEXT B 52920000
         L     8,MB                                                     53100000
         EX    0,MOVEB                                                  53280000
LP1      LR    10,2                SAVE B POINTER                       53460000
         QUEND                                                          53640000
         BCT   9,LOOP              STILL MORE ?                         53820000
LP2      L     15,RETURN           ALL DONE                             54000000
         L     12,CALLBASE                                              54180000
         BR    15                                                       54360000
         EJECT                                                          54540000
*              INSERT A CONSTANT INTO A DIMENSION VECTOR                54720000
*              R3 = NUMBER OF BYTES TILL INSERT                         54900000
*              R0 = CONSTANT TO BE STORED                               55080000
*              R9 = START ADDRESS                                       55260000
INSERT   SH    9,=H'4'             NEW START ADDRESS                    55440000
         LTR   3,3                 0 MEANS NOTHING TO MOVE              55620000
         BNP   INS1                                                     55800000
         BCTR  3,0                 GET MOVE CODE FROM BYTE COUNT        55980000
         EX    3,INSMVC                                                 56160000
         LA    3,1(3)              MAINTAIN INDEX                       56340000
         AR    9,3                 POINTER TO INSERT LOCATION           56520000
INS1     ST    0,0(9)                                                   56700000
         BR    1                                                        56880000
         EJECT                                                          57060000
*              ADJUST CONSTANTS AND PREPARE FOR LOOP                    57240000
*              ON ENTRY                                                 57420000
*                R8 = M-REL START OF ARGUMENT                           57600000
*                R3 = #ELEMENTS OF ARG MOVED AT ONCE                    57780000
*              ON EXIT                                                  57960000
*                R8 = ADDRESS FOR START OF LOOP ON ARG                  58140000
*                R7 = LENGTH OF ONE ELEMENT OF ARG                      58320000
*                R6 = BRANCH TO PROPER MOVE ROUTINE                     58500000
*              LINKAGE  :   BAL 4,ADJUST                                58680000
ADJUST   L     6,NOP               IF NOTHING TO MOVE                   58860000
         LTR   3,3                 NOP USED FOR EXECUTED ROUTINE        59040000
         BNP   0(4)                                                     59220000
         SR    5,5                                                      59400000
         IC    5,MTYPE(8)                                               59580000
         LA    8,MRANK-M(8)        AT RANK  M-REL                       59760000
         LH    7,M(8)                                                   59940000
         LA    8,2(7,8)            AT DATA M-REL                        60120000
         LTR   7,7                 IS ARG SCALAR ?                      60300000
         BZ    ACVTS               YES EXTEND IT                        60480000
         IC    7,LEN1-1(5)         LENGTH OF AN ITEM                    60660000
AN0      C     5,RSTYPE            SAME AS RESULT TYPE                  60840000
AD1      BNE   ACVT                NO, MUST CONVERT                     61020000
         BCT   5,AN1               BRANCH IF NOT BOOLEAN                61200000
         L     6,BBITMOV           USE BIT MOVE ROUTINE                 61380000
         SLL   8,3                 MAKE ROOM FOR BIT DISPLACEMENT       61560000
         BR    4                                                        61740000
AN1      L     6,BBYTMOV           WHATEVER IT IS WE MOVE BYTES         61920000
         BR    4                                                        62100000
ACVT     L     6,BCONVERT          USE CONVERT ROUTINE                  62280000
         ST    8,CONVERTL+4        DATA BASE FOR CONVERSION             62460000
         SR    8,8                 USE ELEMENT INDEX                    62640000
         LA    7,1                 LENGTH OF ELEMENT = 1                62820000
         ST    9,CONVERTL          SAVE CONVERT CODE                    63000000
         BR    4                                                        63180000
ACVTS    L     6,BEXTEND           USE SCALAR EXTENSION                 63360000
         ST    8,CONVERTS+4        M-REL DATA BASE                      63540000
         SR    8,8                 USE ELEMENT INDEX                    63720000
         LA    7,1                 LENGHT OF ELEMENT                    63900000
         ST    9,CONVERTS          SAVE CONVERT CODE                    64080000
         BR    4                   RETURN                               64260000
         EJECT                                                          64440000
*              MOVE BITS UP TO 32 AT A TIME                             64620000
*              R6 = RELATIVE BIT ADDRESS OF SINK                        64800000
*              R2 = M-REL BIT ADDRESS OF SOURCE                         64980000
*              R8 = # OF BITS TO MOVE                                   65160000
BITMOVE  ST    6,SINKAD            SAVE STARTING ADDRESSES              65340000
         ST    2,SOURCEAD                                               65520000
         SRDL  6,5                 CHOP OFF BIT DISPLACEMENT            65700000
         SLL   6,2                 FULLWORD ADDRESS                     65880000
         L     0,M(6)         GET SINK WORD                             66060000
         SRL   7,27                DETERMINE AMOUNT OF SHIFT            66240000
         S     7,=F'32'            TO PUT FIRST UNUSED SINK             66420000
         LCR   7,7                 BIT IN BIT 0 OF REG 1                66600000
         SRL   0,0(7)              R7 = # BITS ACCEPTABLE TO SINK       66780000
         SRDL  2,5                 GET BIT DISPLACEMENT IN SOURCE       66960000
         SLL   2,2                 GET FULLWORD ADDRESS OF SOURCE       67140000
         L     1,M(2)              GET A SOURCE WORD                    67320000
         SRL   3,27                DETERMINE SHIFT TO PUT FIRST         67500000
*                                  BIT TO BE MOVED IN BIT 0 OF REG 1    67680000
BITM2    SLL   1,0(3)              LEFT JUSTIFY SOURCE BITS IN R1       67860000
         SLDL  0,0(7)              MOVE SOURCE INTO SINK                68040000
         ST    0,M(6)         STUFF RESULT BACK                         68220000
         L     6,SINKAD                                                 68400000
         L     2,SOURCEAD                                               68580000
         LA    1,32                DETERMINE # BITS PROVIDED BY THE     68760000
         SR    1,3                 SOURCE                               68940000
         CR    1,7                 THE # BITS MOVED = MINIMUM OF        69120000
         BNL   *+6                 NUMBER PROVIDED AND                  69300000
         LR    7,1                 NUMBER ACCEPTABLE                    69480000
         AR    6,7                 UPDATE SINK ADDRESS                  69660000
         AR    2,7                 UPDATE SOURCE ADDRESS                69840000
         SR    8,7                 REDUCE COUNT                         70020000
         BP    BITMOVE             BACK FOR MORE                        70200000
BITDONE  AR    6,8                 UPDATE ADDRESSES ONLY BY             70380000
         AR    2,8                 COUNT REQUESTED.WE MAY               70560000
         BR    LKR                 MOVE TOO MUCH BUT SINCE              70740000
*                                  WE FILL RESULT FROM LOW ADDRESS      70920000
*                                  TO HIGH ADDRESS IT DOESN'T MATTER    71100000
         EJECT                                                          71280000
*              MOVE BYTES UP TO 256 AT A TIME                           71460000
*              R6 = RELATIVE BYTE ADDRESS OF SINK                       71640000
*              R2 = M-REL ADDRESS OF SOURCE                             71820000
*              R8 = # OF BYTES TO MOVE                                  72000000
BYTEMOVE LA    0,256                                                    72180000
         BCTR  8,0                 CHANGE BYTE COUNT TO MOVE COUNT      72360000
         AR    2,MR                MAKE SOURCE ADDRESS ABSOLUTE         72540000
         AR    6,MR           MAKE SINK ADDRESS ABSOLUTE                72720000
         CR    0,8                 NO LOOP IF 256 OR FEWER TO MOVE      72900000
         BH    LASTBYTE            REMEMBER COUNT IS ALREADY REDUCED    73080000
         LA    1,0(6,8)                                                 73260000
         SR    1,0                 CAUSE END OF LOOP WHENEVER 256 OF    73440000
*                                  FEWER LEFT TO MOVE                   73620000
BYTELOOP MVC   0(256,6),0(2)                                            73800000
         AR    2,0                                                      73980000
         BXLE  6,0,BYTELOOP                                             74160000
         N     8,=F'255'           GET 256 RESIDUE OF COUNT             74340000
LASTBYTE EX    8,MOVEBYT           MOVE REMAINDER                       74520000
         LA    6,1(8,6)            UPDATE POINTER TO RESULT             74700000
         LA    2,1(8,2)            UPDATE POINTER TO SOURCE             74880000
         SR    2,MR                RELATIVIZE SOURCE                    75060000
         SR    6,MR           AND SINK                                  75240000
         BR    LKR                                                      75420000
         EJECT                                                          75600000
*              CONVERT ELEMENTS ONE AT A TIME                           75780000
*              R2 = ELEMENT INDEX OF SOURCE                             75960000
*              R6 = RELATIVE BYTE ADDRESS OF SINK                       76140000
*              R8 = NUMBER OF ELEMENTS TO MOVE                          76320000
CONVERT  LM    3,5,CONVERTL        TYPE DATA BASE,LENGTH                76500000
*                                  LENGTH MUST BE MOVE COUNT (0,3,7)    76680000
         LR    7,LKR               SAVE RETURN ADDRESS                  76860000
         AR    6,MR           MAKE SINK ABSOLUTE                        77040000
C2       ICALL FETCH                                                    77220000
         STM   0,1,DBL             STORE LEFT JUSTIFIED IN DBL          77400000
         EX    5,MVC               MOVE PROPER # OF BYTES               77580000
         LA    6,1(5,6)            POINT TO NEXT RESULT SLOT            77760000
         LA    2,1(2)              INCREMENT ELEMENT INDEX              77940000
         BCT   8,C2                                                     78120000
         SR    6,MR           MAKE SINK RELATIVE                        78300000
         BR    7                                                        78480000
         EJECT                                                          78660000
*              EXTEND A SCALAR BY FETCHING FIRST VALUE AND MOVING       78840000
*              THE REST BY MOVE ROUTINES                                79020000
*              R6 = RELATIVE ADDRESS OF SINK                            79200000
*              R8 = NUMBER OF ELEMENTS TO MOVE                          79380000
EXTENDL  LM    3,5,CONVERTA                                             79560000
         B     EXTEND1                                                  79740000
EXTEND   LM    3,5,CONVERTS        TYPE,DATA BASE, LENGTH               79920000
EXTEND1  LR    7,LKR               SAVE RETURN ADDRESS                  80100000
         SR    2,2                 LOOP THINKS ITS AN ARRAY             80280000
EXTE0    ICALL FETCH               GET THE ELEMENT TO BE REPLICATED     80460000
         CLI   RSTYPE+3,1          IF BOOLEAN                           80640000
         BE    EXTB                MOVE BITS FOR EXTENSION              80820000
         STM   0,1,DBL                                                  81000000
         LA    2,M(6)         NEED IT ABSOLUTE                          81180000
         EX    5,MVC2         PUT IN FIRST ELEMENT                      81360000
         LR    2,6            SOURCE IS REST OF SINK                    81540000
         LA    6,1(5,6)            UPDATE SINK ADDRESS                  81720000
         BCT   8,EXTM                                                   81900000
         BR    7                   QUIT EARLY IF ONLY ONE ELEMENT       82080000
         SPACE 2                                                        82260000
EXTM     MR    4,8            DETERMINE NUMBER OF BYTES                 82440000
         AR    8,5                 REMAINING TO MOVE                    82620000
         LR    LKR,7               RESTORE RETURN ADDRESS               82800000
         B     BYTEMOVE            PERFORM OVERLAPPING MVC              82980000
         SPACE                                                          83160000
         SPACE                                                          83340000
EXTB     LR    LKR,7               MOVE BITS UP TO 32 AT A TIME         83520000
         SR    4,4                 R4 IS ALL ZEROS OR ALL ONES          83700000
         LTR   0,0                 DEPENDING UPON THE SCALAR BEING      83880000
         BZ    BITL                A ZERO OR A ONE                      84060000
         BCTR  4,0                 ITS A ONE                            84240000
BITL     ST    6,SINKAD            SAVE STARTING ADDRESS                84420000
         SRDL  6,5                 GET FULLWORD ADDRESS                 84600000
         SLL   6,2                                                      84780000
         SRL   7,27                AND BIT DISPLACEMENT                 84960000
         S     7,=F'32'                                                 85140000
         LCR   7,7                 R7 IS NUMBER OF BITS PROVIDED        85320000
         L     0,M(6)         GET SINK WORD                             85500000
         SRL   0,0(7)              LINE UP SINK ON REG 1                85680000
         LR    1,4                                                      85860000
         SLDL  0,0(7)                                                   86040000
         ST    0,M(6)                                                   86220000
         L     6,SINKAD            PICK UP START ADDRESS                86400000
         AR    6,7                 ADD NUM BITS MOVED                   86580000
         SR    8,7                 REDUCE COUNT                         86760000
         BP    BITL                GO BACK FOR MORE                     86940000
         AR    6,8                 ADJUST FOR LAST MOVE                 87120000
         BR    LKR                                                      87300000
         EJECT                                                          87480000
MOVRHOB  MVC   0(0,10),0(3)        TO MOVE RHOB INTO STACK              87660000
MOVRHOA  MVC   0(0,8),0(3)         TO MOVE RHOA INTO STACK              87840000
MOVBTOA  MVC   0(0,8),0(10)        MOVE RHOB TO RHOA                    88020000
MOVATOB  MVC   0(0,10),0(8)        MOVE RHOA TO RHOB                    88200000
INSMVC   MVC   0(0,9),4(9)         TO INSERT CONST IN DIMENSION         88380000
MOVATOR  MVC   0(0,7),0(8)         COPY RHOA INTO RHOR                  88560000
MTORES   MVC   0(0,1),DIM          COPY RHOR INTO M-ENTRY               88740000
MOVEBYT  MVC   0(0,6),0(2)                                              88920000
MVC      MVC   0(0,6),DBL                                               89100000
MVC2     MVC   0(0,2),DBL                                               89280000
         DS    0F                  MAKE SURE BRANCH IS ON FULLWORD BOUN 89460000
BBITMOV  BAL   LKR,BITMOVE                                              89640000
BBYTMOV  BAL   LKR,BYTEMOVE                                             89820000
BCONVERT BAL   LKR,CONVERT                                              90000000
BEXTEND  BAL   LKR,EXTEND                                               90180000
BEXTENDL BAL   LKR,EXTENDL                                              90360000
NOP      BCR   0,0                 TO MOVE ZERO BYTES                   90540000
CDIM     CLC   0(0,10),0(8)                                             90720000
RANER    LA    1,ERANK             RANK ERROR                           90900000
         B     ER                                                       91080000
OUT      LA    1,EINDEX            AN INDEX ERROR                       91260000
ER       ICALL ERROR               OH WHAT'S THE USE                    91440000
LEN      DC    AL1(0,3,7,0)        LENGTH CODE PER TYPE                 91620000
LEN1     DC    AL1(1,4,8,1)        LENGTH PER TYPE                      91800000
DONE     DC    D'1'                                                     91980000
RDUNZ    DC    X'4E00000000000000' UNNORMALIZED ZERO                    92160000
TWO31    DC    X'48800000'                                              92340000
PATCH    DC    10H'1'                                                   92520000
         LTORG                                                          92700000
         EJECT                                                          92880000
OPSECT   DSECT                                                          93060000
FINDEX   EQU   INDRANK                                                  93240000
LORG     EQU   *                                                        93420000
DBL      DS    D                   FOR CONVERSIONS                      93600000
CONVERTL DS    3F                  TYPE,DATA BASE,LENGTH CODE           93780000
CONVERTS DS    3F                  SAME FOR SCALARS                     93960000
CONVERTA DS    3F                                                       94140000
*                                                                       94320000
MOVEA    DS    F                   ADDRESS OF PROPER MOVE BRANCH        94500000
MOVEB    DS    F                   SAME FOR B                           94680000
MA       DS    F                   AMOUNT OF A MOVED AT ONE TIME        94860000
MB       DS    F                   AMOUNT OF B MOVED AT ONE TIME        95040000
N        DS    F                   NUMBER OF TIMES TO LOOP              95220000
AAD      DS    F                   IF MOVEBITS = 2**5 * M-REL ADDRESS + 95400000
AID      DS    F                   A INDEXED DIMENSION                  95580000
BID      DS    F                   B INDEXED POSITION                   95760000
*                                  BIT DISPLACEMENT                     95940000
*                                  IF MOVEBYTES = M-RELATIVE ADDRESS    96120000
*                                  IF CONVERT = ELEMENT INDEX           96300000
BAD      DS    F                   SAME FOR B                           96480000
RETURN   DS    F                   RETURN ADDRESS IN OPCTL              96660000
CALLBASE DS    F                   BASE REGISTER OF OPCTL               96840000
SINKAD   DS    F                   TEMP LOC FOR BITMOVE                 97020000
SOURCEAD DS    F                   LIKEWISE                             97200000
DIM      DS    80F                 ALLOW UP TO RANK 24             3067 97380000
LEND     EQU   *                   END OF DSECT                         97560000
         END                                                            97740000
./  ADD    NAME=APLSBLOW
BLOW     TITLE 'FIXED POINT OVERFLOW RECOVERY ROUTINE         05/11/70' 00430000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00860000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01290000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01720000
BLOWUP   CSECT                                                          02150000
         PRINT OFF       APLDEFN, OPSECT                                03010000
         COPY  APLDEFN                                                  03440000
         COPY  OPSECT                                                   03870000
         TITLE 'FIXED POINT OVERFLOW RECOVERY ROUTINE         05/11/70' 04300000
         PRINT ON,NOGEN                                                 04730000
BLOWUP   CSECT                                                          05160000
         EXTRN MBLOWRTN                                                 05590000
         EXTRN BLOWRTN                                                  06020000
         EXTRN OPSPACE                                                  06450000
         EXTRN CLEANUP                                                  06880000
         EXTRN FETCH                                                    07310000
         EXTRN STORE                                                    07740000
         EXTRN ARTHTP                                                   08170000
         SPACE                                                          08600000
*                                                                       09030000
*        1.    MONADIC OPERATOR BLOWUP.                                 09460000
*              RESULT IS NEVER STORED ON OPERAND IN A SITUATION         09890000
*              WHERE A BLOWUP MIGHT OCCUR.                              10320000
*              - MARK CURRENT RESULT GARBAGE, SET UP ARTHTP OPERANDS    10750000
*              TO FORCE A FLOATING RESULT, AND RETURN TO MBLOWRTN       11180000
*        IN OPERATOR CONTROL.                                           11610000
*                                                                       12040000
*        2.    DYADIC OPERATOR BLOWUP.                                  12470000
*        A.    RESULT NOT STORED ON AN OPERAND.                         12900000
*              - TREAT AS IS THE MONADIC CASE AND RETURN TO             13330000
*        BLOWRTN IN OPERATOR CONTROL.                                   13760000
*                                                                       14190000
*        B.    RESULT STORED ON AN OPERAND.                             14620000
*        -     GET SPACE FOR RESULT, CONVERT CALCULATED RESULTS         15050000
*              TO FLOATING, COMPLETE CALCULATION.                       15480000
*                                                                       15910000
         SPACE                                                          16340000
         BALR  9,0                 ESTABLISH ADDRESSING.                16770000
         USING *,9                                                      17200000
         USING OPSECT-16,LR                                             17630000
         SPACE                                                          18060000
*        DETERMINE IF OPERATION WAS MONADIC OR DYADIC.                  18490000
         SPACE                                                          18920000
         MVI   BLOWN,1             TURN ON BLOWUP RECOVERY SWITCH.      19350000
         CLI   LHTYPE+3,0          ZERO LEFT TYPE INDICATES MONADIC.    19780000
         BE    MONABLOW            BRANCH IF MONADIC.                   20210000
         L     1,RBASE             FIND SYNONYM OF RESULT BASE.         20640000
         C     1,LHBASE                                                 21070000
         BE    BLEFT               LEFT ARG IS RESULT                   21500000
         C     1,RHBASE                                                 21930000
         BE    BRIGHT              RIGHT ARG IS RESULT                  22360000
*                                                                       22790000
*        CASE 2A - DYADIC, RESULT NOT ON OPERAND.                       23220000
         SPACE                                                          23650000
DYABLOW  L     10,=A(BLOWRTN)      DYADIC RETURN TO OP CONTROL.         24080000
BLOWCOMM MKG   1                   MARK OLD RESULT GARBAGE.             24510000
         L     1,SVI               MOVE SVI BACK ONE ENTRY.             24940000
         LA    1,4(1)                                                   25370000
         ST    1,SVI                                                    25800000
RSTSVI   LA    0,3                 CAUSE ARTHTP TO FORCE FLOATING RES.  26230000
         BR    10                  RE-ENTER OPERATOR CONTROL.           26660000
         SPACE                                                          27090000
*        CASE  1 - MONADIC.                                             27520000
         SPACE                                                          27950000
MONABLOW L     10,=A(MBLOWRTN)     MONADIC RETRUN TO OP CONTROL.        28380000
         L     1,RBASE             PICK UP OLD RESULT ADDRESS.          28810000
         B     BLOWCOMM            ENTER COMMON CODE.                   29240000
         EJECT                                                          29670000
*                                                                       30100000
*        CASE  2B - RESULT STORED ON A DYADIC OPERAND.                  30530000
*                                                                       30960000
*        R8 CONTAINS REMAINING LOOP COUNT.                              31390000
*                                                                       31820000
BRIGHT   MVI   TEMPRGT,1           RE-MARK RIGHT AS TEMP                32250000
         MVI   LTORRT,2            INDICATE THAT RIGHT HAS RESULT.      32680000
         B     BSPACE                                                   33110000
BLEFT    MVI   TEMPLFT,1           MARK LEFT AS AGAIN TEMP.             33540000
         MVI   LTORRT,1            INDICATE THAT LEFT HAS RESULT.       33970000
BSPACE   ST    8,LHFROUT           HIDE REMAINING COUNT.                34400000
         SPACE                                                          34830000
*        REALIGN EXECUTION STACK.                                       35260000
         SPACE                                                          35690000
         L     3,SVI               PICK UP SVI                          36120000
         LA    3,4(3)              INCREMENT IT.                        36550000
         ST    3,SVI               AND PUT IT BACK.                     36980000
         LA    3,4(3)              POINT AT LEFT OPERAND                37410000
         TM    LTORRT,1            CHECK LEFT OR RIGHT.                 37840000
         BNZ   *+8                 BRANCH IF LEFT                       38270000
         LA    3,12(3)             POINT AT RIGHT OPERAND ON STACK      38700000
         ST    3,MHEAD(1)          RESTORE APPROPRIATE M-ENTRY.         39130000
         L     10,=A(BLOWRTN)                                           39560000
         C     8,RXRHO             SEE IF BLOWUP WAS ON FIRST EL.       39990000
         BE    RSTSVI              DON'T NEED THE FOLLOWING CODE IF SO. 40420000
         SPACE                                                          40850000
*        CAN NOW GET SPACE FOR RESULT.                                  41280000
         SPACE                                                          41710000
         BALR  PR,0                SWITCH PROG BASE TO PR.              42140000
         USING *,PR                                                     42570000
         L     1,RXRHO             GET X / RHO RESULT.                  43000000
         L     2,RRANK             AND RESULT RANK.                     43430000
         LA    3,3                 RESULT THPE IS FLOATING.             43860000
         ST    3,RESTYPE                                                44290000
         L     10,=A(OPSPACE)      CALL COMMON GET SPACE ROUTINE.       44720000
         BALR  LKR,10              RETURN WITH RESULT M-POINTER IN R1.  45150000
         ST    1,RBASE             STORE RESULT BASE.                   45580000
         SPACE                                                          46010000
*        SET UP RESULT RANK, ETC.                                       46440000
         SPACE                                                          46870000
         LA    3,3                 RESULT TYPE.                         47300000
         L     2,LHBASE            PICK UP LEFT BASE.                   47730000
         TM    LTORRT,1            CHECK LEFT OR RIGHT.                 48160000
         BO    *+8                 BRANCH IF LEFT.                      48590000
         L     2,RHBASE            PICK UP RIGHT BASE.                  49020000
         ST    2,BINSAVE           SAVE FOR USE AT CONVERSION.          49450000
         L     4,RRANK             RESULT RANK.                         49880000
         ST    4,MTYPE(1)          STORE RANK.                          50740000
         STC   3,MTYPE(1)          INSERT TYPE CODE.                    51170000
         LTR   4,4                 SEE IF ALL THIS IS FOR A SCALAR.     51600000
         BZ    CARTHTP             BRANCH IF SO. (SHOULDN'T HAPPEN)     52030000
         BCTR  4,0                 OTHERWISE, CONVERT RANK TO SS COUNT. 52460000
         LA    1,MRHO(1)           GET ABSOLUTE POINTER.                52890000
         LA    2,MRHO(2)           TO RANK VECTORS.                     53320000
         EX    4,MOVRANK           AND MOVE IN RESULT RANK.             53750000
         SPACE                                                          54180000
*        NOW, CALL ARTHTP.                                              54610000
         SPACE                                                          55040000
CARTHTP  LA    0,3                 FORCE A FLOATING RESULT.             55470000
         L     1,OPERATOR          GET OPERATOR,                        55900000
         L     2,LHTYPE            LEFT TYPE,                           56330000
         L     3,RHTYPE            RIGHT TYPE,                          56760000
         ICALL ARTHTP              AND CALL ARTHTP.                     57190000
         STM   1,5,TYPINFO         STORE RESULTS.                       57620000
         SPACE                                                          58050000
*        CONVERT PREVIOUSLY CALCULATED RESULTS TO FLOATING.             58480000
         SPACE                                                          58910000
         L     8,RXRHO             CALCULATE LOOP COUNT.                59340000
         S     8,LHFROUT           SUBTRACT HIDDEN REMAINDER.           59770000
         SR    1,1                 ZERO FETCH INDICES.                  60200000
         ST    1,LINDX             USE LEFT FETCH OPERANDS.             60630000
         ST    1,RESINDX           AND RESULT.                          61060000
         L     1,LCTYPE            PICK UP LEFT CONVERSION CODE.        61490000
         TM    LTORRT,1            CHECK LEFT OR RIGHT.                 61920000
         BO    *+8                 BRANCH IF LEFT.                      62350000
         L     1,RCTYPE            OTHERWISE, RIGHT CONVERSION CODE.    62780000
         ST    1,LCFTYPE           CONVERSION CODE FOR FIRST PART.      63210000
         L     1,RBASE             NOW, BASES.                          63640000
         A     1,RRANK                                                  64070000
         LA    1,MRHO-M(1)                                              64500000
         ST    1,RESORG            RESULT BASE.                         64930000
         L     1,BINSAVE           OPERAND WHICH WAS OVERWRITTEN.       65360000
         A     1,RRANK             HAS SAME RANK AS RESULT.             65790000
         LA    1,MRHO-M(1)                                              66220000
         ST    1,LHORG                                                  66650000
         SPACE                                                          67080000
*        CONVERT PREVIOUSLY COMPUTED RESULTS.                           67510000
         SPACE                                                          67940000
CONVERT  LM    2,4,LHFETCH         FETCH OPERANDS.                      68370000
         ICALL FETCH               FETCH FIXED RESULT.                  68800000
         LM    2,4,RESTORE         STORE OPERANDS.                      69230000
         ICALL STORE                                                    69660000
         LA    2,1(2)              UPDATE FETCH INDICES.                70090000
         ST    2,LINDX                                                  70520000
         ST    2,RESINDX                                                70950000
         QUEND                                                          71380000
         BCT   8,CONVERT           LOOP.                                71810000
         SPACE                                                          72240000
*        NOW, COMPLETE EXECUTION.                                       72670000
         SPACE                                                          73100000
         L     8,LHFROUT           PICK UP REMAINING LOOP COUNT.        73530000
         L     1,LHBASE            SET UP FETCH OPERANDS.               73960000
         A     1,LHRANK                                                 74390000
         LA    1,MRHO-M(1)                                              74820000
         ST    1,LHORG             LEFT.                                75250000
         L     1,RHBASE                                                 75680000
         A     1,RHRANK                                                 76110000
         LA    1,MRHO-M(1)                                              76540000
         ST    1,RHORG             RIGHT.                               76970000
         MVC   LCFTYPE(4),LCTYPE   LEFT CONVERSION CODE.                77400000
         MVC   RCFTYPE(4),RCTYPE   RIGHT CONVERSION CODE.               77830000
         MVC   LINDX(4),RESINDX    ELEMENT INDICES.                     78260000
         MVC   RINDX(4),RESINDX                                         78690000
         LA    1,1                 INDEX INCREMENTS.                    79120000
         ST    1,LHFROUT                                                79550000
         ST    1,RHFROUT                                                79980000
*        ASSUMPTION - BOTH OPERANDS ARE NOT SCALAR.                     80410000
         SR    1,1                                                      80840000
         TM    LHSCALAR,1          TEST FOR LEFT SCALAR.                81270000
         BZ    ISRH                BRANCH IF NOT.                       81700000
         ST    1,LINDX             SET FETCH INDEX TO ZERO.             82130000
         ST    1,LHFROUT           AND INCREMENT.                       82560000
         B     COMPUTE             AND ENTER COMPUTE LOOP.              82990000
ISRH     TM    RHSCALAR,1          TEST FOR SCALAR RIGHT.               83420000
         BZ    COMPUTE             BRANCH IF NOT.                       83850000
         ST    1,RINDX             OTHERWISE, ZERO FETCH INDEX.         84280000
         ST    1,RHFROUT           AND INCREMENT.                       84710000
         SPACE                                                          85140000
*        LOOP TO COMPLETE COMPUTATION.                                  85570000
         SPACE                                                          86000000
COMPUTE  L     9,OPRN              GET EXECUTION ROUTINE ADDRESS.       86430000
COMPUTE2 LM    2,4,RHFETCH         FETCH RIGHT OPERAND FIRST.           86860000
         ICALL FETCH                                                    87290000
         STD   0,DTEMP             SAVE OVER NEXT CALL.                 87720000
         A     2,RHFROUT           ADD IN INCREMENT.                    88150000
         ST    2,RINDX             AND SAVE INDEX.                      88580000
         LM    2,4,LHFETCH         NOW FETCH LEFT.                      89010000
         ICALL FETCH                                                    89440000
         A     2,LHFROUT           ADD FETCH INCREMENT.                 89870000
         ST    2,LINDX             AND SAVE IT.                         90300000
         LD    2,DTEMP             PICK UP RIGHT OPERAND.               90730000
         BALR  LKR,9               EXECUTE OPERAND.                     91160000
         STD   0,DTEMP             THESE TWO INSTRUCTION MIGHT NOT BE N 91590000
         LM    0,1,DTEMP           NECESSARY.                           92020000
         LM    2,4,RESTORE         PICK IP STORE OPERANDS.              92450000
         ICALL STORE               AND STORE RESULT.                    92880000
         LA    2,1(2)              INCREMENT STORE INDEX.               93310000
         ST    2,RESINDX                                                93740000
         QUEND                     LET SOMEONE ELSE IN.                 94170000
         BCT   8,COMPUTE2          AND LOOP.                            94600000
         SPACE                                                          95030000
*        RECOVERY IS COMPLETE.                                          95460000
         SPACE                                                          95890000
         L     PR,=A(CLEANUP)      RE-ENTER OPERATOR CONTROL.           96320000
         BR    PR                                                       96750000
         SPACE 5                                                        97180000
MOVRANK  MVC   0(0,1),0(2)                                              97610000
         LTORG                                                          98040000
         END                                                            98470000
./  ADD    NAME=APLSDIOT
DIOT     TITLE 'DYADIC IOTA - INVERSE INDEXING                05/11/70' 00330000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00660000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00990000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01320000
         PRINT OFF       APLDEFN, OPSECT                                01980000
EXIOTA   CSECT                                                          02310000
         COPY  APLDEFN                                                  02640000
         COPY  OPSECT                                                   02970000
         TITLE 'DYADIC IOTA - INVERSE INDEXING                05/11/70' 03300000
         PRINT ON,NOGEN                                                 03630000
*                                                                       03960000
*        INVERSE INDEXING.                                              04290000
*                                                                       04620000
*        R = A IOTA B                                                   04950000
*        A MUST BE VECTOR.                                              05280000
*        B IS ARBITRARY.                                                05610000
*                                                                       05940000
*        (RHO R) = RHO B.                                               06270000
*                                                                       06600000
*        R(I) = J SUCH THAT B(I) = A(J) WHERE J IS MINIMUM, OR IF       06930000
*        0 = OR/B(I) = A, THEN R(I) = 1+RHO A.                          07260000
*                                                                       07590000
         SPACE                                                          07920000
EXIOTA   CSECT                                                          08250000
         USING *,9                                                      08580000
         USING OPSECT-16,LR                                             08910000
         ST    LKR,TEMPRES         SAVE THE LINK.                       09240000
         SPACE                                                          09570000
         L     1,LHRANK            FIRST, MAKE SURE LH IS VECTOR.       09900000
         C     1,IOTA4                                                  10230000
         BE    SETUP               BRANCH IF SO.                        10560000
         LA    1,ERANK             OTHERWISE,                           10890000
         ICALL ERROR               GIVE A RANK ERROR.                   11220000
         SPACE                                                          11550000
*                                                                       11880000
*        CALCULATE, AND GET SPACE.                                      12210000
*                                                                       12540000
         SPACE                                                          12870000
SETUP    L     1,RHXRHO            NEED SAME NO. OF ELS AS RHS.         13200000
         L     2,RHRANK            PICK UP THE RANK.                    13530000
         LA    3,2                 INTEGER TYPE.                        13860000
         L     10,=A(OPSPACE)      GET ENTRY INTO COMMON GETSPACE.      14190000
         BALR  LKR,10              AND ENTER IT.                        14520000
         EJECT                                                          14850000
*                                                                       15180000
*        NOW, SET UP HEADER.                                            15510000
*                                                                       15840000
         SPACE                                                          16170000
         LR    8,1                 MOVE RESULT BASE TO R8.              16500000
         L     1,RHRANK            PICK UP RESULT RANK.                 16830000
         ST    1,MTYPE(8)          PUT INTO RESULT.                     17490000
         LA    1,2                 INTEGER TYPE.                        17820000
         STC   1,MTYPE(8)                                               18150000
         L     7,RHBASE            PICK UP RIGHT BASE.                  18480000
         LA    7,MRHO(7)           ABSOLUTE POINTER TO RANK VECTOR      18810000
         LA    6,MRHO(8)           ABS POINTER TO RESULT RANK VECTOR.   19140000
         L     5,RHRANK            NUMBER OF BYTES TO MOVE.             19470000
         LTR   5,5                 SEE IF WE HAVE A SCALAR              19800000
         BZ    RANKIN              BRANCH IF SO.                        20130000
         BCTR  5,0                 FOR THE OFFSET.                      20460000
         EX    5,MOVRANK           RANK MOVED IN.                       20790000
         SPACE                                                          21120000
*                                                                       21450000
*        NOW, SET UP FOR FETCHES.                                       21780000
*                                                                       22110000
         SPACE                                                          22440000
RANKIN   EQU   *                                                        22770000
         L     4,LHXRHO            SEE IF LEFT IS EMPTY.                23100000
         LTR   4,4                                                      23430000
         BZ    LHEMPTY             BRANCH IF SO.                        23760000
         L     4,LHBASE                                                 24090000
         A     4,LHRANK                                                 24420000
         LA    4,MRHO-M(4)                                              24750000
         ST    4,LHORG             LEFT BASE.                           25080000
         L     4,LCTYPE                                                 25410000
         ST    4,LCFTYPE           LEFT FETCH TYPE.                     25740000
         L     4,RHBASE                                                 26070000
         A     4,RHRANK                                                 26400000
         LA    4,MRHO-M(4)                                              26730000
         ST    4,RHORG             RIGHT BASE.                          27060000
         L     4,RCTYPE                                                 27390000
         ST    4,RCFTYPE           FETCH CODE FOR RIGHT.                27720000
         A     8,RHRANK            NOW, SET UP RESULT BASE.             28050000
         LA    8,MRHO-M(8)         WE'RE POINTED.                       28380000
         L     7,RHXRHO            NUMBER OF TIMES THROUGH.             28710000
         L     6,COMTYP            COMPUTE TYPE.                        29040000
         SR    2,2                                                      29370000
         ST    2,RINDX                                                  29700000
         ST    2,LINDX                                                  30030000
         LTR   7,7                 TEST FOR NONE.                       30360000
         BNZ   DECIDE              BRANCH IF NOT.                       30690000
         L     LKR,TEMPRES                                              31020000
         BR    LKR                 WE'RE FINISHED.                      31350000
         EJECT                                                          31680000
*                                                                       32010000
*        EXECUTE TYPE DEPENDENT ROUTINES.                               32340000
*                                                                       32670000
         SPACE                                                          33000000
DECIDE   L     4,LHTYPE            SEE IF BOTH OPERANDS ARE BOOLEAN.    33330000
         O     4,RHTYPE                                                 33660000
         BCT   6,*+4                                                    33990000
         BCT   4,MBEFIX            BRANCH IF NOT BOOLEAN.               34320000
         SPACE                                                          34650000
*                                                                       34980000
*        BOOLEAN IS FAST - FIRST 0, OR FIRST 1.                         35310000
*        OTHER THAN 1 OR 0 IN EITHER OPERAND IS IMPOSSIBLE.             35640000
*                                                                       35970000
         SPACE                                                          36300000
BOOLIOTA EQU   *                                                        36630000
         L     6,LHXRHO            LOOK FOR FIRST ZERO.                 36960000
LKFRZERO BAL   5,FETCHLFT          FETCH A LEFT.                        37290000
         LTR   0,0                 SEE IF WE HAVE A ZERO.               37620000
         BZ    GOTZERO             BRANCH IF SO.                        37950000
         QUEND                                                          38280000
         BCT   6,LKFRZERO          OTHERWISE, LOOP.                     38610000
         LA    2,1(2)              BUMP INDEX BY 1.                     38940000
GOTZERO  S     2,IOTA1             SUBTRACT 1 FROM INDEX.               39270000
         ST    2,A                 SAVE THIS.                           39600000
         L     6,LHXRHO            LOOK FOR FIRST 1.                    39930000
         SR    2,2                                                      40260000
         ST    2,LINDX                                                  40590000
LKFRONE  BAL   5,FETCHLFT          FETCH A LEFT.                        40920000
         LTR   0,0                 SEE IF IT'S A 1.                     41250000
         BNZ   GOTONE              BRANCH IF SO.                        41580000
         QUEND                                                          41910000
         BCT   6,LKFRONE           OTHERWISE, LOOP.                     42240000
         LA    2,1(2)              BUMP INDEX.                          42570000
GOTONE   S     2,IOTA1             SUBTRACT 1 FROM INDEX.               42900000
         L     3,A                 PICK UP INDEX OF FIRST ZERO.         43230000
         A     2,IORIGIN           ADD IN INDEX ORIGIN.                 43560000
         A     3,IORIGIN                                                43890000
         STM   2,3,A                                                    44220000
         SPACE                                                          44550000
*        GO TO IT, STORING APPROPRIATE INDEX DEPENDING ON ORIGIN.       44880000
*                                                                       45210000
         SPACE                                                          45540000
BOOLOOP  BAL   5,FETCHRIT          FETCH A RIGHT.                       45870000
         LM    2,3,A                                                    46200000
         LTR   0,0                 TEST IT.                             46530000
         BNZ   ITSAONE             BRANCH IF ONE.                       46860000
         ST    3,M(8)              STORE INDEX OF FIRST ZERO.           47190000
         B     BOOLBUMP            AND BRANCH.                          47520000
ITSAONE  ST    2,M(8)              STORE INDEX OF 1ST ONE.              47850000
BOOLBUMP LA    8,4(8)              BUMP RESULT POINTER.                 48180000
         QUEND                                                          48510000
         BCT   7,BOOLOOP           AND LOOP.                            48840000
         SPACE                                                          49170000
         L     LKR,TEMPRES         PICK UP LINK.                        49500000
         BR    LKR                 AND DEPART.                          49830000
         EJECT                                                          50160000
*                                                                       50490000
*        CTYPE INTEGER - SIMPLE LOOPS.                                  50820000
*        (ALSO HANDLES CHAR,CHAR)                                       51150000
*                                                                       51480000
         SPACE                                                          51810000
MBEFIX   BCT   6,MBEFLT            BRANCH IF NOT INTEGER.               52140000
         SPACE                                                          52470000
*                                                                       52800000
*        OUTER LOOP ON X/RHO B.                                         53130000
*                                                                       53460000
         SPACE                                                          53790000
FIXOUTER SR    2,2                 REINITIALIZE LEFT FETCH INDEX.       54120000
         ST    2,LINDX                                                  54450000
         L     6,LHXRHO            AND INNER LOOP COUNT.                54780000
         BAL   5,FETCHRIT          FETCH A RIGHT.                       55110000
         ST    0,RHSAVE            AND SAVE IT.                         55440000
*                                                                       55770000
*        INNER LOOP ON X/RHO A.                                         56100000
*                                                                       56430000
FIXINNER BAL   5,FETCHLFT          FETCH A LEFT.                        56760000
         C     0,RHSAVE            COMPARE TO CURRENT RIGHT.            57090000
         BE    FIXHIT              BRANCH ON A HIT.                     57420000
         QUEND                                                          57750000
         BCT   6,FIXINNER          END OF INNER LOOP.                   58080000
         LA    2,1(2)              BUMP UP INDEX ON FALL-THRU.          58410000
         SPACE                                                          58740000
FIXHIT   A     2,IORIGIN           ADD IN INDEX ORIGIN.                 59070000
         S     2,IOTA1             SUBTRACT 1 FOR FETCH OVERSHOOT.      59400000
         ST    2,M(8)              STORE RESULT ELEMENT.                59730000
         LA    8,4(8)              KICK UP RESULT POINTER.              60060000
         QUEND                                                          60390000
         BCT   7,FIXOUTER          END OF OUTER LOOP.                   60720000
         SPACE                                                          61050000
         L     LKR,TEMPRES                                              61380000
         BR    LKR                                                      61710000
         EJECT                                                          62040000
*                                                                       62370000
*        CTYPE FLOAT - FUZZ IS INVOLVED.                                62700000
*                                                                       63030000
         SPACE                                                          63360000
MBEFLT   BCT   6,CHARACTR          BRANCH IF CHARACTER.                 63690000
         SPACE                                                          64020000
*                                                                       64350000
*        OUTER LOOP - SAME AS CTYPE FIXED.                              64680000
*                                                                       65010000
         SPACE                                                          65340000
FLTOUTER SR    2,2                 REINITIALIZE LEFT FETCH INDEX.       65670000
         ST    2,LINDX                                                  66000000
         L     6,LHXRHO            INNER LOOP COUNT.                    66330000
         BAL   5,FETCHRIT          FETCH A RIGHT.                       66660000
         STD   0,DBLSAVE           SAVE IT.                             66990000
         SPACE                                                          67320000
*                                                                       67650000
*        INNER LOOP.                                                    67980000
*                                                                       68310000
         SPACE                                                          68640000
FLTINNER BAL   5,FETCHLFT          FETCH A LEFT.                        68970000
         SW    0,DBLSAVE                                                69300000
         STD   0,DTEMP                                                  69630000
         CLC   DTEMP+1(7),RFUZZ+1                                       69960000
         BNH   FLTHIT              BRANCH LOW OR EQUAL - A HIT.         70290000
         QUEND                                                          70620000
         BCT   6,FLTINNER          END OF INNER LOOP.                   70950000
         LA    2,1(2)              BUMP ON FALL THROUGH.                71280000
         SPACE                                                          71610000
FLTHIT   A     2,IORIGIN           ADD IN INDEX ORIGIN.                 71940000
         S     2,IOTA1             SUBTRACT 1 FOR FETCH OVERSHOOT.      72270000
         ST    2,M(8)              STORE RESULT ELEMENT.                72600000
         LA    8,4(8)              BUMP RESULT POINTER.                 72930000
         QUEND                                                          73260000
         BCT   7,FLTOUTER          END OF OUTER LOOP.                   73590000
         SPACE                                                          73920000
         L     LKR,TEMPRES         PICK UP LINK.                        74250000
         BR    LKR                                                      74580000
         EJECT                                                          74910000
*                                                                       75240000
*        CTYPE CHARACTER.                                               75570000
*        TWO POSSIBILITIES...                                           75900000
*        1)    BOTH TYPES CHAR - USE INTEGER LOOPS.                     76230000
*        2)    ONE TYPE NOT CHARACTER - NO HITS.                        76560000
*                                                                       76890000
         SPACE                                                          77220000
CHARACTR L     2,LHTYPE            PICK UP LEFT TYPE                    77550000
         C     2,RHTYPE                                                 77880000
         BE    FIXOUTER            USE FIXED IF EQUAL.                  78210000
         SPACE                                                          78540000
         L     2,LHXRHO            OTHERWISE, ALL RESULT ELEMENTS       78870000
         A     2,IORIGIN           ADD IN INDEX ORIGIN.                 79200000
         SPACE                                                          79530000
MIXCHAR  ST    2,M(8)              STORE IN RESULT.                     79860000
         LA    8,4(8)              BUMP RESULT POINTER.                 80190000
         BCT   7,MIXCHAR           END OF LOOP.                         80520000
         SPACE                                                          80850000
         L     LKR,TEMPRES                                              81180000
         BR    LKR                                                      81510000
         SPACE                                                          81840000
*                                                                       82170000
*        LH OPERAND EMPTY VECTOR.                                       82500000
*                                                                       82830000
         SPACE                                                          83160000
LHEMPTY  L     6,RHXRHO            SEE IF RIGHT IS ALSO EMPTY.          83490000
         LTR   6,6                                                      83820000
         BNZ   ALLONES             BRANCH IF NOT.                       84150000
         L     LKR,TEMPRES         OTHERWISE, RETURN.                   84480000
         BR    LKR                                                      84810000
         SPACE                                                          85140000
ALLONES  A     8,RHRANK            RESULT IS ALL ONES.                  85470000
         LA    8,MRHO-M(8)                                              85800000
         L     1,IORIGIN           RESULT IS ALL IORIGIN.               86130000
STONES   ST    1,M(8)                                                   86460000
         LA    8,4(8)                                                   86790000
         BCT   6,STONES                                                 87120000
         L     LKR,TEMPRES                                              87450000
         BR    LKR                                                      87780000
         EJECT                                                          88110000
*                                                                       88440000
*        FETCH SUBROUTINES.                                             88770000
*                                                                       89100000
         SPACE                                                          89430000
FETCHLFT LM    2,4,LHFETCH         PICK UP FETC  ARGUMENTS.             89760000
         ICALL FETCH               FETCH.                               90090000
         LA    2,1(2)              BUMP INDEX.                          90420000
         ST    2,LINDX             SAVE IT.                             90750000
         BR    5                   JUMP BACK.                           91080000
         SPACE                                                          91410000
FETCHRIT LM    2,4,RHFETCH         PICK UP FETCH ARGUMENTS.             91740000
         ICALL FETCH                                                    92070000
         LA    2,1(2)                                                   92400000
         ST    2,RINDX                                                  92730000
         BR    5                   THAT'S ALL.                          93060000
         SPACE 5                                                        93390000
*                                                                       93720000
*        CONSTANTS.                                                     94050000
*                                                                       94380000
         SPACE                                                          94710000
         EXTRN ERROR                                                    95040000
         EXTRN OPSPACE                                                  95370000
         EXTRN FETCH                                                    95700000
         SPACE 2                                                        96030000
MOVRANK  MVC   0(0,6),0(7)                                              96360000
IOTA1    DC    F'1'                                                     96690000
IOTA4    DC    F'4'                                                     97020000
         LTORG                                                          97350000
         END                                                            97680000
./  ADD    NAME=APLSDPY
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00400000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00600000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00800000
         PRINT OFF       APLDEFN, ZSYMBOLS, PERTERM                     01000000
DPY      TITLE 'S T A T E M E N T   D I S P L A Y             05/11/70' 01200000
         PRINT NOGEN                                                    01400000
DISPLAY  CSECT                                                          01600000
         COPY  APLDEFN                                                  01800000
         COPY  ZSYMBOLS                                                 02000000
         COPY   PERTERM                                                 02200000
         TITLE 'S T A T E M E N T   D I S P L A Y             05/11/70' 02400000
         PRINT ON                                                       02600000
*              DISPLAYS A STATEMENT RECREATED FROM A CODESTRING.        02800000
*              ON ENTRY,                                                03000000
*              R2 = CODESTRING M-POINTER                                03200000
*              R3 = CODESTRING INDEX OF ERROR BYTE, MINUS 1             03400000
*                 = X'FFXXXXXX' FOR DISPLAY WITH NO ERROR-INDICATION    03600000
         EXTRN FETCH                                                    03800000
         EXTRN LOUT                                                     04000000
         EXTRN LOUTN                                                    04200000
         EXTRN SQUIRT                                                   04400000
         EXTRN SQUIRTM                                                  04600000
         EXTRN TOBCD                                                    04800000
         EXTRN TOPRINT                                                  05000000
CBCONST  EQU   ZBCONST*2+1                                              05200000
CCCONST  EQU   ZCCONST*2+1                                              05400000
CREM     EQU   ZREM*2+1                                                 05600000
DISPLAY  CSECT                                                          05800000
         PROLOG DILOC,DILEND                                            06000000
         STM   2,7,DISRS                                                06200000
         N     2,QF24BITS                                               06400000
         BZ    DISQ                QUIT INSTANTLY IF 'CODESTRING' IS 0  06600000
         LTR   3,3                 IF R3 REALLY IS A CODESTRING INDEX,  06800000
         BM    DIS0                                                     07000000
         AR    3,2                 ADD IN CODESTRING BASE ADDR          07200000
DIS0     STM   2,3,DISCS                                                07400000
         LH    1,OBUFPTR           SAVE CURRENT OUTPUT BUFFER POINTER   07600000
         ST    1,BLFLG             AND CLEAR BLANK-INSERTION FLAG.      07800000
         LA    4,M(2)              GET ABS ADDRESS OF START OF CODESTRN 08000000
         AH    2,MCSCNT(2)         GET REL ADDRESS OF END OF CODESTRING 08200000
         ST    2,LASTSYL           FOR END CHECK ON LEFT-TO-RIGHT SCAN  08400000
         LA    5,0(2,MR)           AND ABS ADDRESS (LESS MCSORG-M-1)    08600000
*                                  FOR RIGHT-TO-LEFT SCAN.              08800000
         MVC   TSIGDIG(1),OSIGDIG+3 SAVE CURRENT OUTPUT SIGNIFICANCE    09000000
         MVI   OSIGDIG+3,16        DISPLAY OUTPUT IS FULL SIGNIFICANCE. 09200000
*              BEFORE WE CAN DISPLAY THE CODESTRING, WE MUST PERMUTE    09400000
*              LONG SYLLABLES AND CONSTANT ENTRIES SO THAT THE LOW-     09600000
*              ORDER BIT OF THE SYLLABLE (WHICH DISTINGUISHES SHORT     09800000
*              FROM LONG) CAN BE RECOGNIZED WHEN WE SCAN LEFT-TO-RIGHT. 10000000
*              THE LEFT-TO-RIGHT SCAN WHICH DOES THE DISPLAY HAS THE    10200000
*              RESPONSIBILITY FOR REPERMUTING THE CODESTRING TO ITS     10400000
*              ORIGINAL STATE.                                          10600000
FLIP1    SR    1,1                 PREPARE TO LOOK AT NEXT SYL          10800000
         ST    1,ERPOS             CLEAR OUTPUT BUFFER POSITION OF ERR  11000000
         IC    1,MCSORG-M-1(5)                                          11200000
         TM    MCSORG-M-1(5),1     IS SYL SHORT OR LONG --              11400000
         BO    FLIP3               SHORT.                               11600000
         MVC   MCSORG-M-1(1,5),MCSORG-M-2(5)  LONG.  INTERCHANGE BYTES. 11800000
         STC   1,MCSORG-M-2(5)                                          12000000
         BCT   5,FLIP4             DROP POINTER 1 EXTRA FOR LONG SYL    12200000
*              PERMUTE FIRST AND LAST THREE BYTES OF A CONSTANT.        12400000
FLIP3    S     1,QACB              IS SHORT SYL A CONSTANT BEGINNER --  12600000
         CL    1,QF6                                                    12800000
         BH    FLIP4               NO.  NO ACTION ON OTHER SHORT SYLS.  13000000
         MVC   FLTEMP(3),MCSORG-M-3(5) PUT COUNT ON HALFWD BNDRY.       13200000
         LH    2,FLTEMP            FROM COUNT                           13400000
         IC    1,FLIN(1)           AND TYPE                             13600000
         SLL   2,0(1)              COMPUTE NUMBER OF DATA BITS.         13800000
         LA    2,7+16(2)           ROUND UP (FOR BOOLEAN) AND ADD 2     14000000
         SRL   2,3                 (FOR COUNT) AND MAKE IT A BYTE COUNT 14200000
*              NOW R2 = NO. OF BYTES IN CONST DATA AND COUNT            14400000
*                  R5 = ADDR OF TYPE SYL + 1 (LESS MCSORG-M)            14600000
         LNR   2,2                                                      14800000
         AR    2,5                 POSITION R2 TO LEFT END OF CONST     15000000
         MVC   MCSORG-M-3(3,5),Q210    MOVE FIRST 3 BYTES TO LAST,      15200000
         TR    MCSORG-M-3(3,5),MCSORG-M-1(2)  REVERSED.                 15400000
         MVC   MCSORG-M-1(3,2),Q201  MOVE TYPE AND COUNT BYTES TO FIRST 15600000
         TR    MCSORG-M-1(3,2),FLTEMP  3 BYTES, WITH TYPE PRECEDING CNT 15800000
         LR    5,2                                                      16000000
FLIP4    BCTR  5,0                 MOVE R5 TO NEXT PRECEDING BYTE       16200000
         CR    5,4                 IF IT EQUALS THE CODESTRING ADDRESS, 16400000
         BH    FLIP1               WE'RE DONE.                          16600000
*                                                                       16800000
*        NOW WE'RE READY FOR THE REVERSE (PRINTING) SCAN.               17000000
*        LONG SYLLABLES            B1  B2,0                             17200000
*        LOOK LIKE ...             B2,0  B1                             17400000
*                                                                       17600000
*        CONSTANT SYL STRINGS      C1  C2  C3  C4  C5 ... CN  CNT  CS,1 17800000
*        LOOK LIKE ...             CS,1  CNT  C4  C5 ... CN  C3  C2  C1 18000000
*                                                                       18200000
*              R4 IS POINTER (ALTERNATELY RELATIVE AND ABSOLUTE)        18400000
*                 TO SYLLABLE OF INTEREST, LESS MCSORG-M .              18600000
         MVI   REMTOG,CCCONST      ASSUME NORMAL APL STATEMENT          18800000
         CLI   MCSORG-M(4),CREM    UNLESS IT'S A COMMENT LINE,          19000000
         BNE   *+8                                                      19200000
         MVI   REMTOG,0            FOR WHICH USE UNUSUAL OUTPUT FMT     19400000
DIS1     LA    1,512               REENTRY AFTER DISPLAYING A SYLLABLE  19600000
         IC    1,MCSORG-M(4)                                            19800000
         TM    MCSORG-M(4),1       LOOK AT LENGTH OF NEXT SYLLABLE      20000000
         BZ    DIS2                IF LONG SYLLABLE, 1-BIT IS 0.        20200000
         SR    4,MR                R4 IS NOW RELOCATABLE                20400000
         SRL   1,1                 ZSYMBOL CODE IS (SYL-1)/2.           20600000
         STH   1,TEC               STORE IT WITH CHAR CNT FOR SQUIRT    20800000
         LA    3,TOSSE-1           SEARCH TABLE OF EXCEPTIONAL SHORT    21000000
*                                  SYLLABLES.                           21200000
DIS1E    CLC   TEC+1(1),0(3)       TABLE IS ORDERED, SO WE CAN EXIT     21400000
         BH    DIS1B               ON HIGH.                             21600000
         BE    *+8                 EXCEPTIONAL MATCH                    21800000
         BCT   3,DIS1E             ALWAYS BRANCHES                      22000000
         SR    1,1                                                      22200000
         IC    1,TOSR-TOSS(3)      REPLACEMENT GRAPHIC OR MAGIC CODE    22400000
         SR    2,2                                                      22600000
         IC    2,TOSA-TOSS(3)      BRANCH ADDR OF EXCEPTION ROUTINE     22800000
         B     DIS1D(2)                                                 23000000
DIS1D    MVC   TEC(3),QZTORS       T DELTA OR S DELTA                   23200000
DIS1A    STC   1,TEC+1             STRAIGHTFORWARD REPLACEMENT          23400000
DIS1B    LA    1,2                 UNEXCEPTIONAL CHARACTERS             23600000
DIS1C    BAL   5,BLINS             PARENS AND BRACKETS.  R1 IS BLANK-   23800000
*                                  INSERTION CODE                       24000000
         SR    0,0                 RECALL NUMBER OF CHARS               24200000
         IC    0,TEC               (1 EXCEPT FOR TRACE AND STOP)        24400000
         BAL   LKR,DISUB           CHECK CARRIER SPACING                24600000
         LA    1,TEC               FINALLY PRINT THE CHAR               24800000
         ICALL SQUIRT                                                   25000000
DIS1N    BCT   4,DIS9              DROP R4 BY 1 BEFORE ADDING 2.        25200000
*                                  THE BCT ALWAYS BRANCHES.             25400000
*                                                                       25600000
DIS1L    LH    1,OBUFPTR           LABELLED END-OF-STATEMENT CHAR       25800000
         BCTR  1,0                 EXDENT ONE                           26000000
DIS1K    STH   1,OBUFPTR                                                26200000
         BCT   4,DIS9              COMMENT AT DIS1N APPLIES             26400000
*                                                                       26600000
*              LEFT-TO-RIGHT SCAN -- CONSTANT SYLLABLE.                 26800000
*                                                                       27000000
DIS3     AR    4,MR                ABSOLUTIZE R4                        27200000
         MVC   FLTEMP+1(3),MCSORG-M(4) MOVE TYPE AND COUNT TO FLTEMP    27400000
         SR    3,3                                                      27600000
         ST    3,DCJ               CLEAR VECTOR INDEX BEFORE PRINT LOOP 27800000
         IC    3,FLIN-1(1)         SAVE ELEMENT LENGTH FOR LATER USE    28000000
         ST    3,DCN                                                    28200000
         IC    3,FLIN-2(1)         NOW FIND BYTE LENGTH OF CONSTANT     28400000
         SRL   1,1                 CODESTRING ENTRY.                    28600000
         ST    1,DCT                                                    28800000
         LH    2,FLTEMP+2          PICK UP CONST COUNT                  29000000
         SLL   2,0(3)                                                   29200000
         LA    2,7+8(2)            ROUND UP TO A BYTE AND ADD 1 FOR     29400000
         SRL   2,3                 THE OVERHEAD SYLLABLES.              29600000
         AR    2,4                                                      29800000
*              NOW R4 = ABS ADDRESS OF LEFTMOST BYTE (TYPE SYLLABLE),   30000000
*                       LESS MCSORG-M                                   30200000
*                  R2 = ABS ADDRESS OF NEXT-TO-RIGHTMOST BYTE,          30400000
*                       LESS MCSORG-M                                   30600000
         MVC   MCSORG-M(3,4),Q210  PUT THE CODESTRING BACK TOGETHER.    30800000
         TR    MCSORG-M(3,4),MCSORG-M-1(2)                              31000000
         MVC   MCSORG-M-1(3,2),Q201+2  THIS SHOULD BE THE INVERSE OF    31200000
         TR    MCSORG-M-1(3,2),FLTEMP+1  THE MVC'S AND TR'S IN R-L SCAN 31400000
         SR    2,MR                RELATIVIZE POINTER                   31600000
         ST    2,FCSP              TO BE PICKED UP TO RESUME DISPLAY.   31800000
         SR    4,MR                RELATIVIZE POINTER TO LEFT END OF    32000000
         ST    4,DCO                                                    32200000
         CLI   REMTOG,CCCONST      IF THIS IS A COMMENT,                32400000
         BNE   DIS3C               AVOID ALL THE BLANK-INSERTION LOGIC  32600000
         LA    1,X'18'             PREPARE TO INSERT SPACES             32800000
         CLI   FLTEMP+1,CCCONST                                         33000000
         BE    DIS3D               ALWAYS ON CHARACTER CONSTANTS        33200000
         CLC   FLTEMP+2(2),QH1                                          33400000
         BNH   *+8                                                      33600000
         LA    1,X'1F'             EVEN MORESO ON NUMERIC VECTORS       33800000
         BAL   5,BLINS                                                  34000000
         B     DIS3A                                                    34200000
DIS3D    BAL   5,BLINS                                                  34400000
         LA    1,ZQUOTE            IF THIS IS CHARACTER-TYPE VECTOR,    34600000
         B     DIS3M               START OFF WITH A QUOTE MARK.         34800000
DIS3P    CLI   FLTEMP+1,CCCONST                                         35000000
         BE    DIS3C               IF THIS ISN'T CHARACTER VECTOR,      35200000
         LA    1,ZBLANK            PUT A SPACE BETWEEN ELEMENTS.        35400000
DIS3M    BAL   LKR,DISUBON4         CHECK FOR FIT INTO OBUF        3571 35600000
         ICALL TOPRINT             SP, OR INITL QUOTE OF CHARCONST 3571 35800000
DIS3A    CLI   FLTEMP+1,CBCONST    WHAT KIND OF CONSTANT IS THIS --     36000000
         BE    DIS3B               BOOLEAN.                             36200000
DIS3C    L     4,DCO                CURRENT POINTER INTO CONSTANT  3571 36400000
         LA    1,M(4)               ABS ADDR FOR NON-BOOLEAN.      3571 36600000
         MVC   DTEMP(8),MCSORG-M(1)    MOVE IN ENOUGH BYTES TO DTEMP    36800000
         A     4,DCN               BUMP DATA ADDRESS                    37000000
         ST    4,DCO                                                    37200000
DIS3X    CLC   FLTEMP+1(1),REMTOG  IF CHARACTER TYPE (NOT COMMENT)      37400000
         BNE   DIS3R                                                A02 37600000
DIS3XX   OC    FLTEMP+2(2),FLTEMP+2  AND EMPTY VECTOR -- E.G. '',   A02 37800000
         BE    DIS3S               QUIT RIGHT NOW.                      38000000
         CLI   DTEMP,ZQUOTE        OR, IF ELEMENT IS A QUOTE,           38200000
         BE    DIS3G               PRINT AN EXTRA QUOTE.                38400000
         CLI   DTEMP,ZCR           OR IF ELEMENT IS A RETURN,           38600000
         BNE   DIS3F                                                    38800000
         L     4,MPTBASE                                                39000000
         TM    IOB1-PERTERM(4),COPYWM  AND WE'RE NOT A COPY SOURCE,     39200000
         BO    DIS3F                                                    39400000
         L     0,OBUFLIM           FORCE END-OF-LINE                    39600000
         BAL   LKR,DISUB           IN LIEU OF PRINTING CR.              39800000
         B     DIS3V                                                    40000000
DIS3G    LA    1,ZQUOTE                                                 40200000
         BAL   LKR,DISUBON4         SEE IF ONE MORE WILL FIT       3571 40400000
         ICALL TOPRINT                                                  40600000
         B     DIS3F                                                    40800000
DIS3B    LM    2,4,DCJ             BOOLEAN FETCH.                       41000000
         LA    4,MCSORG-M(4)                                            41200000
         ICALL FETCH               USE THE FETCH SUBROUTINE -- IT'S     41400000
         ST    0,DTEMP             EASIER.                              41600000
DIS3F    L     2,DCT                                                    41800000
         SR    3,3                                                      42000000
         SR    0,0                 FOR LINE-LENGTH ESTIMATION, ASSUME   42200000
         IC    0,LPERT-1(2)        MAXIMUM LENGTH FOR EACH TYPE.        42400000
         SR    4,4                 DON'T LET DISUB MARK ERROR POSITION  42600000
         BAL   LKR,DISUB           CHECK VISIBILITY AND CARETIZING      42800000
         LM    0,1,DTEMP                                                43000000
         ICALL TOBCD               PRINT VALUE WITH WIDTH = 0           43200000
*                                  REENTRY FOR QUOTED CR                43400000
DIS3V    L     1,DCJ                                                    43600000
         LA    1,1(1)              BUMP ELEMENT INDEX                   43800000
         ST    1,DCJ                                                    44000000
         CH    1,FLTEMP+2          BACK TO PRINT THE NEXT ELEMENT       44200000
         BL    DIS3P               UNLESS INDEX GTR CONSTANT COUNT      44400000
         EX    0,DIS3X             CHECK FOR CHAR TYPE AND NOT COMMENT  44600000
         BNE   DIS3N                                                    44800000
*              REENTRY FOR EMPTY CHARACTER VECTOR                       45000000
DIS3S    LA    1,ZQUOTE            TO PRINT A CLOSING QUOTE.            45200000
         BAL   LKR,DISUBON4        ROOM FOR ONE MORE CHAR Q        3571 45400000
         ICALL TOPRINT                                                  45600000
DIS3N    L     4,FCSP              PICK UP SYLLABLE INDEX               45800000
         SR    0,0                 CHECK ERROR ON PRECEDING CONSTANT    46000000
         BAL   LKR,DISUB                                                46200000
         B     DIS9                                                     46400000
DIS3R    EQU   *                                                    A02 46600000
         EX    0,DIS3XX            CHECK FOR COMMENT LINE WITH      A02 46800000
*                                   ZERO-LENGTH CHARACTER STRING.   A02 47000000
         BNE   DIS3F               BRANCH IF NON-ZERO               A02 47200000
         B     DIS3N               ZERO                             A02 47400000
         SPACE 2                                                        47600000
DIS2     MVC   MCSORG-M(1,4),MCSORG-M+1(4)  LONG SYLLABLE.              47800000
         STC   1,MCSORG-M+1(4)     REARRANGE PERMUTED BYTES.            48000000
         MVC   FLTEMP(2),MCSORG-M(4)                                    48200000
         SR    4,MR                RELATIVEIZE R4 AGAIN                 48400000
         LH    1,FLTEMP            PICK UP LONG SYLLABLE                48600000
         SLA   1,2                 MAKE IT DOUBLE-WORD INDEX            48800000
         BZ    DIS9                IF SYL REPRESENTS NONEXISTENT        49000000
*                                  PARAMETER, IGNORE IT COMPLETELY.     49200000
         A     1,QR13STK           MAKE IT M-RELATIVE                   49400000
         LA    1,M+4(1)            THEN ABSOLUTE                        49600000
         CLI   0(1),4              IS PRINT NAME LONG OR SHORT --       49800000
         BL    DIS2B               SHORT                                50000000
         L     1,0(1)              LONG                                 50200000
         LA    1,MPNAME(1)         POINT R1 AT LONG PRINT NAME IN M     50400000
DIS2B    LR    7,1                 SAVE PRINTNAME POINTER          3571 50800000
         LA    1,X'18'                                                  51000000
         BAL   5,BLINS             CHECK FOR BLANK-INSERTION            51200000
         SR    0,0                                                      51400000
         IC    0,0(,7)             GET THE ITEM LENGTH             3571 51600000
         BAL   LKR,DISUB                                                51800000
         CLI   ERSYL,2             IS THIS ERR DISPLAY             3571 52000000
         BNH   DIS2C               YES, DON'T GO NEAR SQUIRT       3571 52200000
         LR    1,7                 NO, SEND PRINTNAME OUT          3571 52400000
         ICALL SQUIRT                                              3571 52600000
         B     DIS9                ON TO NEXT SYL                  3571 52800000
DIS2C    CLI   ERSYL,1             PRINTING MAY BE A DEAD ISSUE    3571 53000000
         BE    DIS9                IT IS, BAG IT.                  3571 53200000
         SR    5,5                 NO. R5 GETS LENGTH              3571 53400000
         IC    5,0(,7)             OF PRINTNAME                    3571 53600000
         LH    1,OBUFPTR           R1 GETS WHERE WE ARE            3571 53800000
         LH    0,OBUFLIM           R0 GETS HOW FAR WE CAN GO       3571 54000000
         SR    0,1                 R0 GETS HOW MUCH WE CAN MOVE    3571 54200000
         CR    5,0                 WILL WHOLE NAME FIT             3571 54400000
         BNH   DIS2D               YES, BR                         3571 54600000
         LR    5,0                 NO, MOVE WHAT WILL              3571 54800000
DIS2D    LA    1,OBUF(1)           ABSOLUTE BUFFER POINTER         3571 55000000
         EX    5,DIS2MVC           MOVE PRINTNAME                  3571 55200000
*   ---BUT DON'T CALL LOUT, AS SQUIRT MIGHT HAVE DONE---           3571 55400000
         AH    5,OBUFPTR           UPDATE                          3571 55600000
         STH   5,OBUFPTR             POINTER                       3571 55800000
DIS9     LA    4,2(4)              REENTRY FOR CONSTS AND SHORT SYLS    56000000
         C     4,LASTSYL           BUMP CS POINTER AND TEST FOR END OF  56200000
         LA    4,M(4)              (RE-ABSOLUTIZE R4 W/O SETTING CC)    56400000
         BL    DIS1                CODESTRING                           56600000
         SR    4,MR                                                     56800000
         CLI   ERSYL,2             ALL DONE WITH DISPLAY.               57000000
         BNH   DIS9A               FUNCTION DISPLAY AND ERROR DISPLAY   57200000
         ICALL LOUT                FORCE OUT A PRINT LINE DIFFERENTLY.  57400000
         B     DIS9B                                                    57600000
DIS9A    LH    0,OBUFLIM                                                57800000
         BAL   LKR,DISUB           FORCE OUT LAST LINE OF STATEMENT     58000000
DIS9B    XC    OBUFPTR(2),OBUFPTR  AND RESET OUTPUT POINTER TO LEFT MAR 58200000
         MVC   OSIGDIG+3(1),TSIGDIG                                     58400000
DISQ     LM    2,7,DISRS                                                58600000
         IRETURN                   GIN AND QUIT.                        58800000
         SPACE 2                                                   3571 59000000
DIS2MVC  MVC   0(1,1),1(7)         MOVE PRINTNAME TO BUFFER        3571 59200000
         SPACE 5                                                        59400000
*        DISPLAY SUBROUTINE                                             59600000
*        IF THIS IS ERROR DISPLAY (FIRST BYTE OF ERSYL NOT FF),         59800000
*        WE PRINT ONLY THE LINE CONTAINING THE ERROR, AND A CARET.      60000000
*        IF THIS IS FUNCTION DISPLAY, WE PRINT THE ENTIRE STATEMENT.    60200000
*                                                                       60400000
*        ON ENTRY, R0 = CHARACTER COUNT OF LATEST SYM.                  60600000
*                                                                       60800000
*              POSSIBLE VALUES OF FIRST BYTE OF ERSYL ARE ...           61000000
*              00    ERROR PRINT, ERROR SYLLABLE NOT FOUND YET          61200000
*              01    ERROR PRINT, LINE CONTAINING ERROR ALREADY PRINTED 61400000
*                    DO NOT PRINT ANY FURTHER LINES.                    61600000
*              02    ERROR PRINT, ERROR SYLLABLE FOUND IN CURRENT LINE  61800000
*              FF    FUNCTION DISPLAY.  PRINT ALL LINES.                62000000
*                                                                       62200000
DISUBON4 SR    4,4                  DO NOT SET ERSYL (DESTROY R4)  3571 62400000
         LA    0,1                  LENGTH OF ONE CHAR FOR TOPRINT 3571 62600000
DISUB    ST    1,DISUBT            WE KILL ONLY REGISTER 0.             62800000
         ST    LKR,DISUBR                                               63000000
DISUB1   AH    0,OBUFPTR           ADD IN CARRIAGE POSITION             63200000
         CH    0,OBUFLIM           ARE WE OFF THE END --                63400000
         BNL   DISUB2              YES.  ANALYZE FURTHER.               63600000
         CLI   ERSYL,0             IF THIS IS ERR DPY WITH UNPRINTED ER 63800000
         BCR   7,LKR               (WHICH IT'S NOT),                    64000000
         CL    4,ERSYL             AND WE JUST PASSED THE ERROR SYL,    64200000
         BCR   4,LKR                                                    64400000
*                                  SAVE THE CURRENT CARRIAGE POSITION   64600000
         LH    0,OBUFPTR           FOR PRINTING THE CARET.              64800000
         SH    0,ERLIN2            COMPENSATE FOR ZLF ON LINE 2    3571 65000000
         STH   0,ERPOS             CARET POINTER                   3571 65200000
         MVI   ERSYL,2             INDICATE ERROR SYL IN THIS LINE      65400000
         BR    LKR                                                      65600000
DISUB2   CLI   ERSYL,2             IF WE DONT PRINT THIS LINE      3571 65800000
         BL    DISUB4              THEN BRANCH TO DON'T PRINT IT   3571 66000000
* THIS IS ERROR DSPLY & ERROR LINE, OR FUNCTION DSPLY, OR ) COPY   3571 66200000
         L     1,MPTBASE           FIRST CHECK FOR )COPY DISPLAY   3571 66400000
         TM    IOB1-PERTERM(1),COPYWM   IS IT                      3571 66600000
         BZ    DISUB2A             NO, BR, AND PRINT ON TERMINAL   3571 66800000
* THIS IS COPY DISPLAY, PRINT WITH NO CARRIER RETURN, AND EXIT     3571 67000000
         ICALL LOUTN               SHOOT IT OVER                   3571 67200000
         B     DISUBX              RETURN TO CALLER                3571 67400000
* THIS IS EITHER FUNCTION DISPLAY OR ERROR DISPLAY                 3571 67600000
DISUB2A  CLI   ERSYL,2             IS IT WHICH ONE                 3571 67800000
         BNE   DISUB7              FN DISPLAY, PRINT NORMALLY      3571 68000000
* DEFINITELY ERROR DISPLAY. NOW DO WE SPACE FORE OR AFT TO CARET.  3571 68200000
         LH    1,OBUFPTR           POINT TO VIRTUAL TYPEBALL       3571 68400000
         SH    1,ERPOS             AND KNOW WHICH LINE-HALF        3571 68600000
         CH    1,ERPOS             IF RESULT IS HIGH WE SPACE      3571 68800000
         BH    DISUB7              -SO DO IT                       3571 69000000
         SH    1,ERLIN2            BACKSPACE ONE LESS ON LINE 2    3571 69200000
         STH   1,ERPOS             REMEMBER BKSP COUNT TO CARET    3571 69400000
         LH    1,OBUFPTR           NOW, IT MAY SEEM ODD THAT       3571 69600000
         LA    0,ZLF               WE DONT USE TOPRINT FOR THIS    3571 69800000
         STC   0,OBUF(1)           BUT TOPRINT MIGHT CALL LOUT,    3571 70000000
         LA    1,1(,1)             WHICH WE CAN'T TOLERATE HERE    3571 70200000
         STH   1,OBUFPTR           YEA, VERILY.                    3571 70400000
         ICALL LOUTN               SHOVE IT OUT, AND THEN PREPARE  3571 70600000
         MVI   OBUF,ZBS            (OBUFPTR - ERPOS) BACKSPACES.        70800000
         B     DISUB5                                                   71000000
DISUB7   ICALL LOUT                                                     71200000
         MVI   OBUF,ZBLANK                                              71400000
         CLI   ERSYL,2             FOR FUNCTION DISPLAY,                71600000
         LA    1,6                                                      71800000
         BH    DISUB6              PRINT 6 BLANKS FOR INDENTATION       72000000
DISUB5   LH    1,ERPOS             SP/BKSP COUNT TO ERR CARET      3571 72200000
DISUB6   STH   1,OBUFPTR           PRINT BLANKS UP TO THE ERROR SYL POS 72400000
         EX    1,DISMVC                                                 72600000
         CLI   ERSYL,2             FUNCTION DISPLAY QUITS NOW           72800000
         BH    DISUBX                                                   73000000
         LA    1,ZAND              ERROR LINE PRINTS A CARET            73200000
         ICALL TOPRINT                                                  73400000
         ICALL LOUT                                                     73600000
         MVI   ERSYL,1             INDICATE ERROR LINE HAS BEEN PRINTED 73800000
         B     DISUBX                                                   74000000
DISUB4   LH    1,OOPTR             THIS IS A LINE WE DON'T WANT TO      74200000
         LA    1,1(1)              PRINT.  RESET OBUFPTR TO THE         74400000
         STH   1,OBUFPTR           BEGINNING OF THE LINE (ALLOWING FOR  74600000
         LA    0,ZLF               A LONG FUNCTION NAME.)               74800000
         STC   0,OBUF-1(1)         PUT IN A LINEFEED                    75000000
*                                  TO DISTINGUISH PRINTED LINE FROM     75200000
*                                  FIRST LINE OF STATEMENT.             75400000
         CLI   ERSYL,0             IF WE HAVEN'T YET SEEN THE ERROR3571 75600000
         BNE   DISUBX                (BUT WE HAVE)                 3571 75800000
         CL    4,ERSYL             IT MAY BE THAT THE CARET        3571 76000000
         BL    DISUB4X             IS RIGHT ON THE WIDTH           3571 76200000
         BCTR  1,0                 IT IS, COMPENSATE FOR ZLF       3571 76400000
         STH   1,ERPOS             BEFORE NEXT PASS WE WANT        3571 76600000
         MVI   ERSYL,2             TO NOTE WE SAW THE ERROR        3571 76800000
DISUB4X  MVI   ERLIN2+1,1          REMEMBER WE DROPPED A LINE      3571 77000000
DISUBX   L     LKR,DISUBR                                               77200000
         L     1,DISUBT                                                 77400000
         BR    LKR                                                      77600000
*                                                                       77800000
*        THE BLANK-INSERTION SUBROUTINE.                                78000000
*                                                                       78200000
*        A BLANK IS INSERTED BETWEEN THE FOLLOWING PAIRS OF SYMBOLS...  78400000
*              IDENTIFIER          CONSTANT                             78600000
*              IDENTIFIER          IDENTIFIER                           78800000
*              CONSTANT            IDENTIFIER                           79000000
*              CONSTANT            CONSTANT                             79200000
*              VECTOR CONSTANT     ANY SPECIAL EXCEPT PARENS & BRACKETS 79400000
*              A.S.E.P&B           VECTOR CONSTANT                      79600000
*              ), RBR              CONSTANT OR IDENTIFIER               79800000
*                                                                       80000000
*        ALL THIS IS DONE VIA THE BLANK FLAG, WHOSE VALUE DEPENDS ON    80200000
*        THE TYPE OF CURRENT SYMBOL AS FOLLOWS ...                      80400000
*        IDENTIFIER    X'18'                                            80600000
*        NUMERIC VECTOR                                                 80800000
*           CONSTANT   X'1F'                                            81000000
*        OTHER CONST   X'18'                                            81200000
*        SPECIALS      X'02'                                            81400000
*        ) RBR         X'20'                                            81600000
*        ( LBR         X'00'                                            81800000
*        THE INSERTION CRITERION IS                                     82000000
*              OR / NEW-BLANK-FLAG AND 1 RIGHT-ROTATE OLD-BLANK-FLAG    82200000
*        TO AVOID INSERTION BETWEEN CONSECUTIVE SPECIALS.               82400000
*                                                                       82600000
BLINS    EX    1,BLITM             IS BLANK-INSERTION REQUIRED --       82800000
         SRL   1,1                 CLEVERLY MODIFY FLAG                 83000000
         STC   1,BLFLG             BEFORE STORING IT FOR NEXT SYMBOL    83200000
         BCR   8,5                 NO BLANKS NEEDED.                    83400000
*        MAKE SURE THAT WE HAVE SPACE IN OBUF FOR THIS BLANK       3571 83600000
         LH    1,OBUFPTR           TEST BUFFER FULL AS DISUB DO    3571 83800000
         LA    1,1(,1)             TO ALLOW FOR ZLF                3571 84000000
         CH    1,OBUFLIM                                           3571 84200000
         BNL   BLINS2              BR TO FORGET BLANK, NEW LINE    3571 84400000
         STH   1,OBUFPTR           UPDATE PTR AS TOPRINT DOES      3571 84600000
         AR    1,MR                                                3571 84800000
         MVI   OBUF-1-M(1),ZBLANK  STICK IN THE BLANK              3571 85000000
         BR    5                    RETURN                         3571 85200000
BLINS2   ST    5,DISUBR             SET RETURN ADDR FOR DISUB      3571 85400000
         B     DISUB2               GO TO DISUB END-OF-LINE CODE   3571 85600000
BLITM    TM    BLFLG,0             EXECUTED TM                          85800000
*                                                                       86000000
DISMVC   MVC   OBUF+1(0),OBUF                                           86200000
QH1      DC    H'1'                                                     86400000
Q201     DC    FL1'2,0,1,2,0'                                           86600000
Q210     DC    FL1'2,1,0'                                               86800000
FLIN     DC    FL1'0,0,5,4,6,8,3,1' BYTE-COUNT AND SHIFT-COUNT VALUES   87000000
LPERT    DC    FL1'1,10,23,1'      MAX LENGTH OF CONST, BY TYPE    3571 87200000
*              TABLE OF EXCEPTIONAL SYMBOLS                             87400000
TOSS     DC    AL1(ZILG,ZEOS,ZLEOS,ZDUM,ZFCOLON,ZFPER,ZECONST,ZBCONST)  87600000
         DC    AL1(ZICONST,ZFCONST,ZCCONST,ZLBR,ZRBR,ZLPAR,ZRPAR)       87800000
         DC    AL1(ZFE,ZFOVB,ZTDELTA,ZSDELTA)                           88000000
TOSSE    EQU   *                                                        88200000
*              REPLACEMENTS FOR EXCEPTIONAL SYMBOLS                     88400000
TOSR     DC    AL1(0)              UNUSED                               88600000
QZTORS   DC    AL1(2,2,ZDELTA)     JUST SAVING A 3-BYTE CONSTANT --     88800000
*                                  POSITIONS 1 AND 3 ABOVE UNUSED       89000000
         DC    AL1(ZCOLON,ZPER,ZREM,2,4,6,8,0,X'20',0,X'20')            89200000
         DC    AL1(ZE,ZOVB,ZT,ZS)                                       89400000
*              ADDRESSES OF EXCEPTION ROUTINES                          89600000
TOSA     DC    AL1(DIS1N-DIS1D,DIS1N-DIS1D,DIS1L-DIS1D,DIS1N-DIS1D)     89800000
         DC    3AL1(DIS1A-DIS1D)                                        90000000
         DC    4AL1(DIS3-DIS1D),4AL1(DIS1C-DIS1D),2AL1(DIS1A-DIS1D)     90200000
         DC    2AL1(DIS1D-DIS1D)                                        90400000
QACB     DC    A(ZBCONST*2+1)                                           90600000
QF24BITS DC    A(X'FFFFFF')                                             90800000
QF6      DC    F'6'                                                     91000000
         LTORG                                                          91200000
DILOC    DSECT                                                          91400000
DTEMP    DS    D                                                        91600000
DISRS    DS    6F                                                       91800000
DISUBT   DS    F                   TEMP FOR R1 WHILE IN DISUB           92000000
DIS2T    DS    F                                                        92200000
DISUBR   DS    A                   TEMP FOR LINK TO DISUB               92400000
FLTEMP   DS    F                                                        92600000
ERPOS    DS    F                   POSITION OF ERROR SYLLABLE OR 0      92800000
ERLIN2   EQU   ERPOS+2             LINE FEED COMPENSATION FIELD    3571 93000000
LASTSYL  DS    F                   REL ADDRESS OF LAST CODESTRING SYL   93200000
FCSP     DS    F                   FUTURE CODESTRING POINTER (DIS3)     93400000
DCN      DS    F                                                        93600000
DCJ      DS    3F                  INDEX TO CONSTANT VECTOR ELEMENT     93800000
DCT      EQU   DCJ+4               TRUE TYPE OF CONST                   94000000
DCO      EQU   DCJ+8               OFFSET TO ADDRESS CONST IN CODESTR   94200000
DISCS    DS    2F                  CODESTRING M-POINTER                 94400000
ERSYL    EQU   DISCS+4             POSITION OF ERROR SYLLABLE OR 0      94600000
         DS    0F                                                       94800000
BLFLG    DS    F                   BLANK-INSERTION FLAG                 95000000
OOPTR    EQU   BLFLG+2             ORIGINAL VALUE OF OBUFPTR            95200000
TSIGDIG  DS    FL1                 PRESERVED OUTPUT-SIGNIFICANCE VALUE  95400000
         DS    0H                                                       95600000
TEC      DS    3FL1                TEMPS FOR EXCEPTIONAL CHARACTERS     95800000
REMTOG   DS    FL1                 = CCCONST IF NOT DISPLAYING COMMENT  96000000
DILEND   EQU   *                                                        96200000
         END                                                            96400000
./  ADD    NAME=APLSDQRY
DQRY     TITLE 'D Y A D I C   Q U E R Y                       05/11/70' 00570000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01140000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01710000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       02280000
         PRINT OFF       APLDEFN, OPSECT                                03420000
EXRANDOM CSECT                                                          03990000
         COPY  APLDEFN                                                  04560000
         COPY  OPSECT                                                   05130000
         TITLE 'D Y A D I C   Q U E R Y                       05/11/70' 05700000
         PRINT ON,NOGEN                                                 06270000
EXRANDOM CSECT                                                          06840000
         SPACE                                                          07410000
         EXTRN ERROR                                                    07980000
         EXTRN OPSPACE                                                  08550000
         EXTRN FETCH                                                    09120000
         EXTRN RANDOM                                                   09690000
         ENTRY EXRANDOM                                                 10260000
         USING OPSECT-16,LR                                             10830000
*                                                                       11400000
*        DYADIC QUERY              A QUERY B                            11970000
*        A AND B MUST BE ONE COMPONENT.                                 12540000
*        A= RHO RESULT.                                                 13110000
*        RESULT = 'A' ELEMENTS CHOSEN RANDOMLY WITHOUT REPLACEMENT FROM 13680000
*              IOTA B.                                                  14250000
         BALR  9,0                                                      14820000
         USING *,9                                                      15390000
         ST    LKR,CURRES          SAVE THE LINK REGISTER.              15960000
         LA    1,ERANK             READY TO TEST FOR RANK ERRORS        16530000
         SPACE                                                          17100000
         L     2,LHXRHO            TEST NO. OF ELEMENTS IN LEFT         17670000
         BCT   2,RKERR             RANK ERROR IF NOT 1-ELEMENT.         18240000
         SPACE                                                          18810000
         L     2,RHXRHO            TEST NO. OF ELEMENTS IN RIGHT        19380000
         BCT   2,RKERR             RANK ERROR IF NOT 1-ELEMENT.         19950000
         SPACE                                                          20520000
         L     4,LHBASE            READY TO FETCH LEFT OPERAND          21090000
         A     4,LHRANK                                                 21660000
         L     3,LCTYPE            FETCH CONVERSION CODE.               22230000
         BAL   7,TSTFETCH          FETCH OPERAND AND TEST FOR NEGATIVE  22800000
         BL    RGERR               DOMAIN ERROR IF 'A' NEGATIVE         23370000
         ST    0,LHSAVE            SAVE IT.                             23940000
         SPACE                                                          24510000
         L     4,RHBASE            READY TO FETCH RIGHT OPERAND         25080000
         A     4,RHRANK                                                 25650000
         L     3,RCTYPE            CONVERSION CODE.                     26220000
         BAL   7,TSTFETCH          FETCH OPERAND                        26790000
********* THIS 'BAL' ALSO INITIALIZES REGISTER 7 .GT. ZERO TO INDICATE  27360000
********* THE FAST DYADIC QUERY.                                        27930000
         ST    0,RHSAVE            SAVE IT.                             28500000
         SPACE                                                          29070000
         L     1,LHSAVE            READY FOR RESERVE SPACE = RHO A      29640000
         B     QUES                                                     30210000
RSVP     LR    6,1                 SAVE RESERVATION LENGTH              30780000
         LA    2,4                 MAKE RANK VECTOR.                    31350000
         LA    3,2                 TYPE IS INTEGER                      31920000
         L     10,=A(OPSPACE)      PICK UP ENTRY TO COMMON GETSPACE.    32490000
         BALR  LKR,10              AND ENTER IT.                        33060000
         ST    1,RESORG            SAVE RESULT.                         33630000
         LR    8,1                 SAVE RESULT BASE                     34200000
*        NOW BUILD RESULT HEADER                                        34770000
         L     1,QATR              SET INTEGER TYPE, VECTOR RANK        35340000
         ST    1,MTYPE(8)                                               36480000
         L     1,LHSAVE            LOAD FINAL LENGH                     37050000
         ST    1,MRHO(8)           AND STORE IT IN HEADER               37620000
         LTR   1,1                 TEST IF NULL RESULT                  38190000
         BZ    SCRAM               IF NULL, SCRAM                       38760000
         LA    8,MRHO-M+4(8)       POINT AT DATA.                       39330000
         B     DQUERY                                                   39900000
SCRAM    L     LKR,CURRES          PICK UP LINK.                        40470000
         BR    LKR                 AND UNLINK.                          41040000
         EJECT                                                          41610000
QUES     CR    1,0                 TEST A AGAINST B                     42180000
         BH    RGERR               DOMAIN ERROR IF A .GT. B             42750000
         SRL   0,4                 R0 = FLOOR (B/16)                    43320000
         CR    1,0                 TEST IF A .LT. R0                    43890000
         BNL   RSVPA               IF NOT, RESERVE SPACE FOR B ELEMENTS 44460000
         SRA   1,6                 OTHERWISE, TEST IF A SMALL ENOUGH    45030000
*                                  FOR SLOW METHOD.                     45600000
         LR    7,1                 R7=0 FOR SLOW, POSITIVE FOR FAST.    46170000
         L     1,LHSAVE            PREPARE FOR SLOW METHOD              46740000
         BZ    RSVP                BRANCH IF CODE INDICATES SLOW METHOD 47310000
RSVPA    L     1,RHSAVE            SET TO RESERVE SPACE FOR IOTA B      47880000
         L     0,SVI               CALC IF ROOM ENOUGH FOR IOTA B       48450000
         S     0,MX                NOW HAVE STACK END TO DATA           49020000
         A     0,MINGL             GARBAGE AVAILABLE                    49590000
         SRL   0,2                 NOW IS WORD COUNT                    50160000
         SR    0,1                 SUBTRACT WORDS NEEDED                50730000
         SRA   0,4                 AND ALLOW FOR 16 MORE WORDS          51300000
         BH    RSVP                BRANCH IF (IOTA B) WILL FIT          51870000
         SR    7,7                 SET R7 FOR SLOW METHOD               52440000
         L     1,LHSAVE            SET FOR SLOW METHOD                  53010000
         B     RSVP                GO RESERVE STORAGE                   53580000
DQUERY   EQU   *                                                        54150000
         L     2,RHSAVE            SET MODULUS FOR FRANDOM              54720000
         LR    5,8                 GET START OF DATA POINTER            55290000
         LA    4,4                 SET UP COUNT FOR LOOP                55860000
         SR    5,4                 INITIALIZE END TEST                  56430000
         L     10,=A(RANDOM)       SET REGISTER FOR RANDOM              57000000
         LTR   7,7                 SET CONDITION FOR FAST OR SLOW       57570000
         BNZ   FAST                                                     58140000
         L     1,ONES              STORE INITIAL BAD DATA               58710000
         ST    1,M(8)                                                   59280000
SLOW     EQU   *                                                        59850000
         BALR  LKR,10              GET THE FIRST RANDOM NUMBER          60420000
*        OUTER LOOP RETURNS TO HERE                                     60990000
         MR    0,2                 BEGIN TO FORM MODULUS                61560000
         SLDL  0,1                 FIX UP ARITHMETIC                    62130000
         A     0,IORIGIN           MODIFY BY ORIGIN                     62700000
         LR    3,8                 INITIALIZE SCAN INDEX TO TOP OF DATA 63270000
         QUEND                     PROTECT AGAINST GHASTLY LOOPS        63840000
SLOWLP   C     0,M(3)              TEST IF NEW NO. = TO GENERATED DATA  64410000
         BE    SLOW                BRANCH TO REGENERATE IF =            64980000
         BXLE  3,4,SLOWLP          TEST IF SCAN THRU                    65550000
         AR    5,4                 UP STORAGE POINTER                   66120000
         ST    0,M(5)              STORE GOOD DATA                      66690000
         BCTR  6,10                FORM ANOTHER NO. IF NOT THRU.        67260000
         B     SCRAM               OTHERWISE, EXIT                      67830000
FAST     EQU   *                                                        68400000
         LR    1,6                 GET COUNT FOR IOTA B                 68970000
         A     1,IORIGIN           READY FOR BCTR                       69540000
         LR    3,2                 COUNT IN BYTES                       70110000
         SLL   3,2                 M*4                                  70680000
         AR    5,3                 NOW R5 IS PROPER FOR END TEST        71250000
         LR    3,8                 GET STORAGE ORIGIN                   71820000
FSTLP    BCTR  1,0                 DECREMENT COUNTER                    72390000
         ST    1,M(3)              STORE (REVERSE IOTA B)               72960000
         BXLE  3,4,FSTLP           CONTINUE IF IOTA B NOT YET GENERATED 73530000
         L     7,LHSAVE            GET A FOR LOOP END TEST              74100000
         SR    6,7                 R6=NO. OF EXCESS WORDS TAKEN         74670000
CALC     BALR  LKR,10              GET A RANDOM NUMBER IN R0 AND R1     75240000
         QUEND                     GIVE UP OCCASIONALLY IF 'A' LARGE    75810000
         MR    0,2                 Q(M-J)                               76380000
         SLDL  0,1                 FIX ARITHMETIC                       76950000
         SLL   0,2                 4*(Q(M-J)                            77520000
         LR    1,0                 FOR LATER INDEXING                   78090000
         AR    1,8                 I=4*(J + Q(M-J))                     78660000
         L     0,M(1)              BEGIN SWAP                           79230000
         L     3,M(8)                                                   79800000
         ST    0,M(8)              R(J)=R(I)                            80370000
         ST    3,M(1)              R(I)=R(J)                            80940000
         AR    8,4                 J = J + 4                            81510000
         BCTR  2,0                 M=M-1                                82080000
         BCT   7,CALC              CONTINUE UNTIL 'A' EXHAUSTED         82650000
         SLL   6,2                 CONVERT TO BYTES                     83220000
         L     2,MX                                                     83790000
         SR    2,6                 RESET MX TO PROPER PLACE             84360000
         ST    2,MX                POINTS TO NEXT AVAILABLE STORAGE     84930000
         L     8,RESORG            GET HEADER POINTER                   85500000
         L     2,MCOUNT(8)         GET VECTOR BYTE COUNT                86070000
         SR    2,6                 RESET TO ACTUAL VECTOR LENGTH        86640000
         ST    2,MCOUNT(8)                                              87210000
         B     SCRAM                                                    87780000
         SPACE                                                          88350000
*        FETCH AND SET CONDITION CODE FOR FETCHED DATA                  88920000
TSTFETCH LA    4,MRHO-M(4)         POINTER TO FIRST ELEMENT             89490000
         SR    2,2                 SET FOR FIRST ELEMENT                90060000
         ICALL FETCH               GET ELEMENT                          90630000
         LTR   0,0                 READY TO TEST                        91200000
         BR    7                   RETURN TO CALLER WITH SIGNED DATA    91770000
         SPACE                                                          92340000
*        ERROR EXITS                                                    92910000
RGERR    LA    1,ERANGE            DOMAIN ERROR                         93480000
RKERR    ICALL ERROR               TAKE ERROR EXIT                      94050000
         SPACE                                                          94620000
*        CONSTANTS.                                                     95190000
*                                                                       95760000
ONES     DC    F'-1'                                                    96330000
QF4      DC    F'4'                                                     96900000
QATR     DC    AL1(2,0,0,4)        MTYPE, MRANK                         97470000
         LTORG                                                          98040000
         END                                                            98610000
./  ADD    NAME=APLSDRHO
DRHO     TITLE 'D Y A D I C   R H O                           05/11/70' 00310000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00620000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00930000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01240000
         PRINT OFF       APLDEFN, OPSECT                                01860000
EXRHO    CSECT                                                          02170000
         COPY  APLDEFN                                                  02480000
         COPY  OPSECT                                                   02790000
         TITLE 'D Y A D I C   R H O                           05/11/70' 03100000
         PRINT ON,NOGEN                                                 03410000
EXRHO    CSECT                                                          03720000
         USING *,9                                                      04030000
         USING OPSECT-16,LR                                             04340000
         SPACE                                                          04650000
         ST    15,CURRES           SAVE THE LINK REGISTER.              04960000
         SPACE                                                          05270000
         L     6,LHRANK            CALCULATE ORIGIN OF LH DATA.         05580000
         A     6,LHBASE                                                 05890000
         LA    6,MRHO-M(6)                                              06200000
         ST    6,LHORG                                                  06510000
         L     1,LHRANK            LEFT OPERAND MUST BE -               06820000
         C     1,RHO4              SCALAR OR VECTOR.                    07130000
         BNH   RANKOK              BRANCH IF SO.                        07440000
         LA    1,ERANK             OTHERWISE,                           07750000
         ICALL ERROR               RANK ERROR.                          08060000
         EJECT                                                          08370000
*                                                                       08680000
*        FIRST, GET SPACE.                                              08990000
*                                                                       09300000
RANKOK   L     3,LHTYPE            FIRST, GET X/LEFT OPERAND.           09610000
         SLA   3,2                 A LA ARTHTP.                         09920000
         LA    3,2(3)                                                   10230000
         IC    3,FTCHTYP-5(3)      GOT IT.                              10540000
         ST    3,LCTYPE            SAVE IT.                             10850000
         SR    2,2                 CLEAR R2.                            11160000
         L     4,LHORG             GET THE ORIGIN OF THE DATA.          11470000
         SR    6,6                                                      11780000
         LA    7,1                                                      12090000
         L     8,LHXRHO            PICK UP NUMBER OF ELEMENTS.          12400000
         C     8,SIXTHREE          SEE IF RANK VECTOR IS TOO LONG.      12710000
         BNH   LLTHOK              BRANCH IF NOT                        13020000
         LA    1,ELENGTH           OTHERWISE, LENGTH ERROR.             13330000
         ICALL ERROR                                                    13640000
LLTHOK   LTR   8,8                 SEE IF THERE ANY.                    13950000
         BZ    RESSCLR             IF NOT, RESULT IS SCALAR.            14260000
XREDUCE  ICALL FETCH               FETCH,                               14570000
         LA    2,1(2)              BUMP INDEX,                          14880000
         LTR   0,0                 TEST ELEMENT.                        15190000
         BM    RNGEROR             BRANCH IF NEGATIVE.                  15500000
         MR    6,0                 MULTIPLY,                            15810000
         LTR   6,6                 REJECT MUCH TOO BIG XRHO             16120000
         BNZ   WSFULL                                                   16430000
         BCT   8,XREDUCE           AND LOOP.                            16740000
         LR    1,7                 X REDUCTION NOW IN R1.               17050000
         ST    1,RXRHO             OTHERWISE, STORE RESULT.             17360000
         L     2,LHXRHO            PICK UP LEFT LENGTH                  17670000
         SLA   2,2                 X 4 TO GET A RANK.                   17980000
         L     3,RHTYPE PICK UP THE TYPE.                               18290000
         L     10,=A(OPSPACE)      CALL COMMON GETSPACE ROUTINE.        18600000
         BALR  LKR,10                                                   18910000
         ST    1,RESORG            STORE RESULTING M-POINTER.           19220000
         L     1,RESORG            AND PICK UP M-POINTER AGAIN.         19530000
         EJECT                                                          19840000
*                                                                       20150000
*        SET UP RESULT HEADING AND RANK VECTOR.                         20460000
*                                                                       20770000
         L     3,RHTYPE            PICK UP RESULT TYPE.                 21080000
         STC   3,MTYPE(1)          AND STORE IT.                        21700000
         L     8,LHXRHO            PICK UP LEFT LENGTH.                 22010000
         LR    3,8                 MOVE IT.                             22320000
GOLDBRIK SLL   3,2                 NOW HAVE RANK OF RESULT.             22630000
         STH   3,MRANK(1)          SO STORE IT.                         23250000
         L     4,LHTYPE            NOW LOOK AT LEFT TYPE.               23560000
         C     4,RHO2              SEE IF IT'S INTEGER.                 23870000
         BE    MOVINT              BRANCH IF SO.                        24180000
         LR    7,1                 MOVE RESULT POINTER TO R7.           24490000
         LA    7,MRHO-M(7)         AND KICK IT.                         24800000
         L     4,LHBASE                                                 25110000
         A     4,LHRANK                                                 25420000
         LA    4,MRHO-M(4)         R4 NOW POINTS TO LH OPERAND.         25730000
         L     3,LCTYPE            GET CONVERSION TYPE.                 26040000
         SR    2,2                 START INDEX AT ZERO.                 26350000
         L     5,LHRANK                                                 26660000
         LTR   5,5                 TEST LH RANK AGAIN.                  26970000
         BZ    MOVSCAL             BRANCH IF ZERO.                      27280000
         SPACE                                                          27590000
RANKLOOP ICALL FETCH               FETCH A DIMENSION.                   27900000
         LA    2,1(2)              BUMP INDEX,                          28210000
         ST    0,M(7)              STORE A DIMENSION,                   28520000
         LA    7,4(7)              BUMP POINTER,                        28830000
         BCT   8,RANKLOOP          AND LOOP.                            29140000
         B     MOVINELS            AND GO REPLICATE.                    29450000
         SPACE                                                          29760000
MOVSCAL  ICALL FETCH               FETCH SCALAR LEFT.                   30070000
         ST    0,M(7)              STORE IT.                            30380000
         LA    7,4(7)              AND BUMP.                            30690000
         B     MOVINELS                                                 31000000
         SPACE                                                          31310000
MOVINT   LA    7,MRHO(1)           ABSOLUTE POINTER TO RESULT.          31620000
         L     6,LHBASE                                                 31930000
         A     6,LHRANK                                                 32240000
         LA    6,MRHO(6)           ABSOLUTE POINTER TO LEFT OPERAND.    32550000
         BCTR  3,0                 KNOCK COUNT DOWN.                    32860000
         EX    3,MOVRANK           BLAST IT IN.                         33170000
         L     7,RESORG            GET 7 POINTED RIGHT.                 33480000
         LA    7,MRHO-M(7)                                              33790000
         LA    7,1(7,3)            ADD IN NUMBER OF RANK BYTES.         34100000
         B     MOVINELS                                                 34410000
*                                                                       34720000
MOVRANK  MVC   0(0,7),0(6)                                              35030000
         EJECT                                                          35340000
*                                                                       35650000
*        NOW MOVE IN ELEMENTS.                                          35960000
*                                                                       36270000
MOVINELS L     8,RHBASE            PICK UP RIGHT.                       36580000
         A     8,RHRANK                                                 36890000
         LA    8,MRHO-M(8)         POINTER TO FIRST ELEMENT.            37200000
         ST    8,RHORG                                                  37510000
         L     6,RHXRHO            RIGHT HAND LENGTH.                   37820000
         L     5,RXRHO             RESULT LENGTH.                       38130000
         LTR   5,5                 SEE IF THERE IS ANY.                 38440000
         BZ    RESEMPTY            BRANCH IF NOT.                       38750000
         LTR   6,6                                                      39060000
         BZ    RNGEROR                                                  39370000
         L     2,RHTYPE            PICK UP TYPE                         39680000
         BCT   2,FIXTELS           BRANCH IF NOT BOOLEAN.               39990000
*                                                                       40300000
*        REPLICATE BOOLEAN ELEMENTS.                                    40610000
*                                                                       40920000
         C     6,RHO1              SEE HOW MANY ON LEFT.                41230000
         BE    MUNCH               IF ONE, BRANCH.                      41540000
         CR    5,6                 OTHERWISE, COMPARE LENGTHS.          41850000
         BNH   MOOCH               EASY IF RESULT SHORTER OR 5Q41C#     42160000
         LR    4,8                 FETCH SET UP.                        42470000
         LA    3,1                 BOOL TO BOOL CONVERSION.             42780000
         SR    2,2                 INDEX OF FIRST ELEMENT.              43090000
         STM   2,4,RHFETCH         SAVE IT.                             43400000
         LR    4,7                 STORE SET UP.                        43710000
         LA    3,1                 BOOLEAN STORE TYPE CODE.             44020000
         STM   2,4,LHFETCH         SAVE IT.                             44330000
         SPACE                                                          44640000
GOLOOP   LM    2,4,RHFETCH         FETCH A RIGHT.                       44950000
         ICALL FETCH                                                    45260000
         LA    2,1(2)              BUMP INDEX.                          45570000
         BCT   6,HOWDOON           BRANCH ON RH COUNT.                  45880000
         L     6,RHXRHO            EXHAUSTED, START OVER.               46190000
         SR    2,2                                                      46500000
HOWDOON  ST    2,RINDX             STORE INDEX.                         46810000
         LM    2,4,LHFETCH         NOW, STORE RESULT.                   47120000
         ICALL STORE               DONE.                                47430000
         LA    2,1(2)              INCREMENT STORE INDEX.               47740000
         ST    2,LINDX             AND SAVE IT.                         48050000
         QUEND                                                          48360000
         BCT   5,GOLOOP            AND LOOP ON RESULT XRHO.             48670000
RESEMPTY L     LKR,CURRES          OTHERWISE,                           48980000
         BR    15                  WE'RE DONE.                          49290000
*                                                                       49600000
*        BOOLEAN - SINGLE RIGHT ELEMENT.                                49910000
*                                                                       50220000
MUNCH    L     1,M(8)              PICK IT UP.                          50530000
         SRA   1,31                SPREAD IT ALONG A WORD.              50840000
         LA    4,31(5)             GET COUNT,                           51150000
         SRL   4,5                 RESULT WORD COUNT.                   51460000
MUNCHEM  ST    1,M(7)              STORE IN RESULT.                     51770000
         LA    7,4(7)              KICK POINTER.                        52080000
         BCT   4,MUNCHEM           AND LOOP.                            52390000
         L     15,CURRES           OR,                                  52700000
         BR    15                  WE'RE DONE.                          53010000
*                                                                       53320000
*        BOOLEAN - RIGHT OPERAND LONGER OR EQUAL.                       53630000
*                                                                       53940000
MOOCH    LA    3,M(7)              NEED ABSOLUTE POINTERS.              54250000
         LA    4,M(8)                                                   54560000
         LA    1,255                                                    54870000
         LA    5,31(5)                                                  55180000
         SRL   5,5                                                      55490000
         SLL   5,2                                                      55800000
         B     RSLTSHRT                                                 56110000
         EJECT                                                          56420000
*                                                                       56730000
*        FIXED, FLOAT, CHARACTER RIGHT OPERAND.                         57040000
*                                                                       57350000
FIXTELS  BCT   2,FLTELS            BRANCH IF NOT FIXED.                 57660000
         SLL   5,2                 MULTIPLY LENGTHS BY 4.               57970000
         SLL   6,2                 TO GET BYTES.                        58280000
         B     MVCLOOP                                                  58590000
         SPACE                                                          58900000
FLTELS   BCT   2,MVCLOOP           FLOAT - BRANCH IF CHARACTER.         59210000
         SLL   5,3                 OTHERWISE, MULTIPLY LENGTHS BY 8.    59520000
         SLL   6,3                 TO GET BYTES.                        59830000
*                                                                       60140000
*        NOW PERFORM GREAT GRONKING MOVE CHARACTERS.                    60450000
*                                                                       60760000
MVCLOOP  LA    1,255               MAXIMUM MOVE COUNT.                  61070000
         LA    3,M(7)              ABS PTR TO RESULT.                   61380000
         LA    4,M(8)              ABS PTR TO RIGHT.                    61690000
         CR    5,6                 COMPARE LENGTHS.                     62000000
         BNH   RSLTSHRT            BRANCH IF RESULT NOT SHORTER.        62310000
*                                                                       62620000
*        RESULT LONGER THAN RH OPERAND.                                 62930000
*                                                                       63240000
         SPACE                                                          63550000
MVCCRAP  LR    2,6                 TURN RH LENGTH                       63860000
         BCTR  2,0                 INTO MVC COUNT.                      64170000
         LR    0,2                 AND SAVE IT.                         64480000
         CR    2,1                 COMPARE TO MAXIMUM MOVE.             64790000
         BH    MAXMOV              BRANCH IF GREATER.                   65100000
         SPACE                                                          65410000
BLOOP    EX    2,MOVER             OTHERWISE, MOVE.                     65720000
         SR    5,0                 SUBTRACT RH COUNT.                   66030000
         BCTR  5,0                 AND SUBTRACT ONE MORE.               66340000
         LR    4,3                 LOAD 'FROM' PTR WITH RESORG.         66650000
         LA    3,1(2,3)            BUMP RESULT POINTER.                 66960000
         LR    2,5                 SET RH COUNT TO RES COUNT.           67270000
         B     RSLTSHRT            AND GO DO AN OVERLAPPED MOVE.        67580000
*                                                                       67890000
MAXMOV   EX    1,MOVER             MOVE 256 BYTES.                      68200000
         LA    4,1(1,4)            KICK RH POINTER.                     68510000
         LA    3,1(1,3)            AND RESULT POINTER.                  68820000
         SR    5,1                 KNOCK DOWN RESULT COUNT.             69130000
         BCTR  5,0                                                      69440000
         SR    2,1                 AND RH COUNT.                        69750000
         LTR   2,2                 SEE IF WE HAD A MULTIPLE OF 256.     70060000
         BZ    STRTOVER            BRANCH IF SO.                        70370000
         BCTR  2,0                 BOTH BY 256.                         70680000
         CR    2,1                 COMPARE REMAINING COUNT TO 255.      70990000
         BH    MAXMOV              STILL GREATER - GO BACK AGAIN.       71300000
         SPACE                                                          71610000
         EX    2,MOVER             OTHERWISE, MOVE REST OF RIGHT.       71920000
STRTOVER LA    4,M(8)              START RH OVER.                       72230000
         LA    3,1(2,3)            KICK RESULT POINTER.                 72540000
         SR    5,2                 DECREMENT RESULT COUNT BY LAST MOVE. 72850000
         LR    2,6                 RELOAD RIGHT COUNT.                  73160000
         BCTR  2,0                 KNOCK IT DOWN.                       73470000
         CR    5,6                 COMPARE LENGTHS AGAIN.               73780000
         BNH   RSLTSHRT            BRANCH IF RESULT NOW NOT LONGER.     74090000
         B     MAXMOV              OTHERWISE, LOOP.                     74400000
         SPACE                                                          74710000
*                                                                       75020000
*        RIGHT SHORTER OR EQUAL RESULT.                                 75330000
*                                                                       75640000
         SPACE                                                          75950000
RSLTSHRT CR    5,1                 SEE IF RESULT IS LESS THAN 255.      76260000
         BH    MOV256              BRANCH IF NOT.                       76570000
         EX    5,MOVER             OTHERWISE, SLAP THEM IN.             76880000
FINI     L     LKR,CURRES                                               77190000
         BR    LKR                                                      77500000
*                                                                       77810000
MOV256   EX    1,MOVER             MOVE IN 256 BYTES.                   78120000
         LA    3,1(1,3)            KICK POINTER.                        78430000
         LA    4,1(1,4)                                                 78740000
         SR    5,1                 KNOCK DOWN COUNT.                    79050000
         LTR   5,5                                                      79360000
         BZ    FINI                                                     79670000
         BCTR  5,0                                                      79980000
         B     RSLTSHRT            AND TRY AGAIN.                       80290000
*                                                                       80600000
MOVER    MVC   0(0,3),0(4)                                              80910000
         EJECT                                                          81220000
*                                                                       81530000
*        SCALAR RESULT.                                                 81840000
*                                                                       82150000
RESSCLR  L     1,RHXRHO                                                 82460000
         LTR   1,1                                                      82770000
         BNZ   MAKESCLR                                                 83080000
         LA    1,ELENGTH                                                83390000
         ICALL ERROR                                                    83700000
MAKESCLR LA    1,1                 NEED 1 ELEMENT.                      84010000
         L     3,RHTYPE            PICK UP THE TYPE.                    84320000
         SR    2,2                 RANK IS ZERO                         84630000
         L     10,=A(OPSPACE)      USE COMMON GETSPACE ROUTINE.         84940000
         BALR  LKR,10                                                   85250000
         L     6,RHBASE            PICK UP RIGHT BASE.                  85560000
         A     6,RHRANK            ADD IN THE RH RANK.                  85870000
         LA    6,MRHO(6)           AND HEAD LENGTH.                     86180000
         LM    4,5,0(6)            PICK UP FIRST DOUBLE WORD.           86490000
         ST    4,MRHO(1)           STORE FIRST ONE.                     86800000
         L     7,RHTYPE            PICK UP THE TYPE.                    87110000
         C     7,RHO3              SEE IF IT'S FLOATING.                87420000
         BNE   BUNNY               BRANCH IF NOT FLOATING.              87730000
         ST    5,MRHO+4(1)         OTHERWISE, STORE SECOND WORD.        88040000
BUNNY    SR    2,2                 CLEAR R2.                            88350000
         STH   2,MRANK(1)          STORE IN RANK.                       88970000
         STC   7,MTYPE(1)          AND THE TYPE.                        89280000
         L     15,CURRES                                                89590000
         BR    15                                                       89900000
         EJECT                                                          90210000
*        ERRORS AND CONSTANTS.                                          90520000
*                                                                       90830000
LNGEROR  LA    1,ELENGTH                                                91140000
         ICALL ERROR                                                    91450000
         SPACE                                                          91760000
RNGEROR  LA    1,ERANGE                                                 92070000
         ICALL ERROR                                                    92380000
WSFULL   LA    1,EMFULL                                                 92690000
         ICALL ERROR                                                    93000000
*                                                                       93310000
         EXTRN ERROR                                                    93620000
         EXTRN FETCH                                                    93930000
         EXTRN STORE                                                    94240000
         EXTRN OPSPACE                                                  94550000
*                                                                       94860000
RHO1     DC    F'1'                                                     95170000
RHO2     DC    F'2'                                                     95480000
RHO3     DC    F'3'                                                     95790000
RHOM4    DC    F'-4'                                                    96100000
RHO4     DC    F'4'                                                     96410000
RHO32    DC    F'32'                                                    96720000
SIXTHREE DC    F'63'                                                    97030000
RHO24    DC    X'02000004'                                              97340000
TWO24    DC    X'01000000'                                              97650000
FTCHTYP  DC    FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'              97960000
         LTORG                                                          98270000
         END                                                            98580000
./  ADD    NAME=APLSDSER
DSER     TITLE 'DIRECTORY SEARCH FOR DISK OPERATIONS          05/11/70' 00160000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00320000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00480000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00640000
         MACRO                                                          00800000
&L       ZTEXT &A                                                       00960000
         LCLA  &I,&N                                                    01120000
         LCLC  &C                                                       01280000
&N       SETA  (K'&A)-2                                                 01440000
&I       SETA  1                  SKIP LEFT QUOTE                       01600000
&L       EQU   &N                                                       01760000
         AIF   (&I EQ &I).A4            APL DEVELOPMENT GLITCH          01920000
.A4      AIF   (&I EQ &N+1).A1                                          02080000
&I       SETA  &I+1                                                     02240000
&C       SETC  '&A'(&I,1)                                               02400000
         AIF   ('&C' NE ' ').A3                                         02560000
&C       SETC  'BLANK'                                                  02720000
         AGO   .A2                                                      02880000
.A3      AIF   ('&C' NE ',').A2                                         03040000
&C       SETC  'COMMA'                                                  03200000
.A2      DC    AL1(Z&C)                                                 03360000
         AGO   .A4                                                      03520000
.A1      MEXIT                                                          03680000
         MEND                                                           03840000
         MACRO                                                          04000000
         ZEND                                                           04160000
         DC    AL1(ZCR,ZEOB)                                            04320000
         MEND                                                           04480000
         MACRO                                                          04640000
&OP      SDPAR &F,&ADR                                                  04800000
         ORG   SDTAB+2*XX&OP                                            04960000
         DC    AL1(&F)                                                  05120000
         DC    AL3(&ADR)                                                05280000
         MEND                                                           05440000
DIRSEAR  CSECT                                                          05760000
         PRINT OFF       APLDEFN, ZSYMBOLS,PERTERM, APLSUPC        2230 05920000
         COPY  APLDEFN                                                  06080000
         COPY  ZSYMBOLS                                                 06240000
         COPY  PERTERM                                                  06400000
         APLSUPC ,                 MAPS SUPPARS AREA IN APLSUP     2230 06560000
VALCON   EQU   0                   AVOIDS ASM ERROR                2230 06720000
         PRINT ON,NOGEN                                                 06880000
         TITLE 'DIRECTORY SEARCH FOR DISK OPERATIONS'                   07040000
         ENTRY DSIRMSG                                                  07200000
         EXTRN GETIME                                                   07360000
         EXTRN KMANHASH                                                 07520000
         EXTRN LIBPARS                                                  07680000
         EXTRN LIBPZ                                                    07840000
         EXTRN LOUT                                                     08000000
         EXTRN PRWSNAME                                                 08160000
         EXTRN SUPPARS             MAPPED BY SUPPARD DSECT         2230 08320000
         EXTRN SQUIRT                                                   08480000
         EXTRN SQUIRTM                                                  08640000
WORKS    DSECT                                                          08800000
         DS    4F                                                       08960000
DIRSMAN  DS    F                   LIBRARY NO FOR ASUP, 2ND DIR UPDATE  09120000
OUT1     DS    F                   CCHH                            DASD 09280000
OUT2     DS    H                   PSFILE                               09440000
DIRSWSQ  DS    2H                  WSQ, WSA FOR ASUP 2ND DIR UPDATE     09600000
ASDIRCHG DS    X'00'               DIRCHG FLAG FOR ASUP            DASD 09760000
DIRCHG   DS    X'01'                                                    09920000
TEMA     DS    F                                                        10080000
GETTEM   DS    6F                  FOR GETRKS                           10240000
OLDLAB   DS    CL16                HOLDS OLD  WFLIB & WFLNAME           10400000
WORKZ    DS    0D                                                       10560000
         COPY  DIRSECT                                                  10720000
         USING WORKS,13                                                 10880000
DIRSEAR  CSECT                                                          11040000
         USING PERTERM,10                                               11200000
         USING CDCPARS,8           PARAMETER FROM APLSUP                11360000
         BALR  12,0                                                     11520000
         USING *,12                                                     11680000
         LA    14,WORKZ            PSEUDO PROLOG                        11840000
         USING PDSDDDD,9                                                12000000
         L     9,=A(SDPAR)                                              12160000
*        START OF SPECIAL DISK PROBLEM STATE ROUTINES                   12320000
         L     10,=A(SUPPARS)      A(PERTERM) FROM PROTECTED CORE  2230 12480000
         L     10,PTBASE-SUPPARD(10)                               2230 12640000
         USING PERCORE,7           APLSUP SETS R7 TO REQUESTOR'S WS     12800000
         MVC   TEMA+1(3),PCADDR                                         12960000
         L     7,TEMA                                                   13120000
         DROP  7                                                        13280000
         MVC   OLDLAB,WFLLIB-M(7)                                       13440000
         ICALL GETIME              DO ONE GETIME AND BE DONE WITH IT    13600000
         ST    1,WFLTIME           ASSUME TIME IS CONSTANT OVER DIRSEAR 13760000
         MVI   DIRCHG,1            FOR GETRKS                           13920000
         L     2,LIBENDMK                                               14080000
         L     0,PDSLIB           LIBRARY NUMBER FROM COMMAND           14240000
         L     1,MANSTAR                                                14400000
         AR    1,MR                                                     14560000
         USING PERLIB,1                                                 14720000
         SR    3,3                 FIND CODE WORD FOR OPERATION         14880000
         IC    3,SDOP                                                   15040000
         AR    3,3                                                      15200000
         LA    3,SDTAB(3)                                               15360000
         B     LIBS1+4             SKIP INCREMENT                       15520000
LIBS1    LA    1,MANENTL(1)        INCREMENT TO NEXT ENTRY              15680000
         CL    0,LIBNUM                                                 15840000
         BE    LIBFND             LIBRARY NUMBER FOUND                  16000000
         CL    2,LIBNUM            TEST FOR END OF LIBRARY              16160000
         BNE   LIBS1              SEARCH NEXT LIBENT                    16320000
         DROP  1                                                        16480000
*        LIBRARY NUMBER NOT FOUND                                       16640000
         CLI   PDSWSN,11           CHAR COUNT OVER 11 MEANS DIRECTORY   16800000
         BH    DSF2                LABEL -- I.E. NAMELESS )SAVE OF      16960000
*                                  CLEAR WS.  REJECT IT.                17120000
         TM    0(3),NOLBM+ADDNL                                         17280000
         BM    WSNFN               'WSNFND' IF LOAD, DROP, COPY         17440000
         BO    ADDNF               ADD NEW LIB OR MAN IF )ADD           17600000
         B     ILSAVE              OTHERWISE IMPROPER LIB REFERENCE     17760000
         SPACE 2                                                        17920000
         USING PERSAVW,4                                                18080000
LIBFND   LR    4,1                                                      18240000
         TM    0(3),NOWS                                                18400000
         L     LKR,0(3)                                                 18560000
         BCR   1,LKR               SKIP WS SEARCH                       18720000
SWS1     CLC   PSLINK,ZERO         SEE IF ANOTHER ENTRY EXISTS.         18880000
         BE    SWS2                                                     19040000
         L     1,PSLINK                                                 19200000
         LR    5,4                FOR USE BY DROP                       19360000
         LA    4,0(1,MR)                                                19520000
*        SCAN NEXT ENTRY                                                19680000
         CLC   PSNAME,PDSWSN                                            19840000
         BNE   SWS1               TRY AGAIN                             20000000
*        FOUND WORKSPACE NAME                                           20160000
         BR    LKR                                                      20320000
         SPACE 2                                                        20480000
*        LOAD OR COPY OPERATION                                         20640000
DSLOAD   CLC   PSPASS,PDSPASS      MATCH PASSWORDS,  DIR & COMMAND      20800000
         BNE   DSLNP               NO MATCH                             20960000
*        LOAD, COPY, SAVE  COMMAND OKAY, DIRECTORY UNCHANGED            21120000
         L     0,PSCYL             PARAMETER TO APLSUP             DASD 21280000
         MVI   ASDIRCHG,0                                          DASD 21440000
         MVC   OUT2,PSFILE                                              21600000
         B     DSEXIT                                                   21760000
DSLNP    TYO   DSLNM1                                                   21920000
         B     SDREJ                                                    22080000
DSLNM1   DC    Y(DSLNM2+1)                                              22240000
DSLNM2   ZTEXT 'WS LOCKED'                                              22400000
         ZEND                                                           22560000
*                                                                       22720000
*              )SAVE, WSNAME FOUND                                      22880000
*                                                                       23040000
DSSAVE   L     0,PSMAN             PREVIOUS SAVER                       23200000
         BAL   LKR,PROTCH2         CHECK RESAVE OKAY IN THIS LIB        23360000
         CLC   OLDLAB,PDSLIB       )LOOK FOR )LOAD A  )SAVE B           23520000
         BNE   DSF4                COMPLAIN UNLESS  )SAVE CONTINUE      23680000
DSF3     CLC   PSLEN,PDSTCNT       SAVE, COMPARE TRACK COUNTS           23840000
         BL    DSF5                WON'T FIT IN OLD SLOT                24000000
*        CHECK TO SEE IF PASSWORD HAS CHANGED                           24160000
         CLC   PDSPASS,PSPASS                                           24320000
         BNE   DSF6                DIRECTORY IS CHANGED                 24480000
         MVI   DIRCHG,0            TELL APLSUP DIR UNCHANGED            24640000
DSF6     LR    3,4                 FOR MKFLAB                           24800000
         MVC   PSPASS,PDSPASS                                           24960000
         BAL   15,MKFLAB                                                25120000
         B     DSEXIT                                                   25280000
*        NEW BLOCK OF TRACKS REQUIRED FOR THIS SAVE                     25440000
DSF5     BAL   15,GETRKS                                                25600000
         LR    1,3              RELATIVE ADDR OF NEW BLOCK              25760000
         AR    3,MR                                                     25920000
         MVC   PSLINK-PERSAVW(4,3),PSLINK                               26080000
         B     DSDROP1          COMPLETE LINKAGE INTO LIST FOR          26240000
*                                  THIS LIBRARY AND SALVAGE OLD         26400000
*                                  SAVE AREA                            26560000
DSF4     CLC   ZCONT,PDSWSN                                             26720000
         BE    DSF3                )LOAD A  )SAVE CONTINUE OKAY         26880000
DSF2     LA    1,SAINB1                                                 27040000
         ICALL SQUIRT                                                   27200000
         LA    1,OLDLAB                                                 27360000
         ICALL PRWSNAME                                                 27520000
         B     SDREJ                                                    27680000
SAINB1   DC    AL1(SAINB2)                                              27840000
SAINB2   ZTEXT 'NOT SAVED, THIS WS IS '                                 28000000
*                                                                       28160000
*                                                                       28320000
*              )DROP, WSNAME FOUND.  R0 = PDSLIB                        28480000
*                                                                       28640000
DSDROP   L     0,PSMAN             CHECK DROP BY VALID MAN NO           28800000
         BAL   LKR,PROTCH2                                              28960000
         CLC   ZCONT,PDSWSN                                             29120000
         BE    DSDROP2             CONTINUE IS NOT PART OF QUOTA        29280000
         SR    7,7                                                      29440000
         BCTR  7,0                                                      29600000
         BAL   LKR,ADJQOT          DECREASE COUNT OF SAVED WORKSPACES   29760000
         DC    AL2(0)                                                   29920000
DSDROP2  L     1,PSLINK                                                 30080000
*        R5 WAS SET BY CODE AT SWS1                                     30240000
         MVC   ASDIRCHG,DIRCHG     1 OR 2 DIRECTORY WRITES REQ'D   DASD 30400000
DSDROP1  ST    1,PSLINK-PERSAVW(5)                                      30560000
         LA    LKR,DSEXIT          RETURN FROM DELINKING SUBROUTINE     30720000
*        UNLINK THIS PERSAVW FROM LIBRARY LIST AND PUT IT ON SALVHED    30880000
DSDRSUB  SR    2,2                                                      31040000
         IC    2,PSLEN             TRACK COUNT                          31200000
         SLL   2,2                                                      31360000
         L     1,SALVHED-4(2)                                           31520000
         ST    1,PSLINK            LINK TO OTHER BLOCKS THIS SIZE       31680000
         SR    4,MR                                                     31840000
         ST    4,SALVHED-4(2)                                           32000000
         BR    LKR                                                      32160000
*                                                                       32320000
         USING PERLIB,1                                                 32480000
DSOFF    LM    4,5,PTABTM                                               32640000
         AR    5,4              COMPUTE TIME,  TODAY                    32800000
         L     4,WFLTIME                                                32960000
         S     4,PTSOTM         CONNECTION TIME  TODAY                  33120000
         LM    2,3,CUMCON       CUMULATIVE TIMES                        33280000
         AR    2,4              CONNECTION                              33440000
         AR    3,5              COMPUTE                                 33600000
         STM   2,3,CUMCON                                               33760000
         NI    PLMISC,255-LIBAUTOL                                      33920000
         TM    PDSWSQI,LIBAUTOL    AUTO-LOAD FUN AND GAMES              34080000
         BZ    *+8                                                      34240000
         OI    PLMISC,LIBAUTOL                                          34400000
SETPASS  MVI   ASDIRCHG,1          DIRECTORY REWRITE REQUIRED      DASD 34560000
         SR    0,0                                                 DASD 34720000
         CLI   PDSPASS,0           CHECK FOR SIGNOFF PASSWORD CHANGES   34880000
         BE    DSEXIT              NO CHANGE TO PASSWORD                35040000
         MVC   SOPASS,PDSPASS      NEW PASSWORD                         35200000
         CLI   PDSPASS,X'FF'                                            35360000
         BNE   DSEXIT                                                   35520000
         XC    SOPASS,SOPASS       EMPTY PASSWORD                       35680000
         B     DSEXIT                                                   35840000
         DROP  1                                                        36000000
*                                                                       36160000
*        )SAVE, WSNAME NOT FOUND  (OR 'IMPROPER REFERENCE')             36320000
*                                                                       36480000
SWS2     CLI   SDOP,XXSAVE                                              36640000
         BNE   WSNFN            WSNAME NOT FOUND, NON SAVE OP           36800000
         BAL   15,PROTCHK          CHECK FOR PROPER MAN/LIB NUMBERS     36960000
         BNL   *+8                 CREDITEE IS LIB NO. IF PRIVATE LIB   37120000
         L     0,PTMAN             AND SAVER IF PUBLIC LIB              37280000
*        NAME NOT FOUND IN SAVE OPERATION, CREATE NEW ENTRY             37440000
         CLI   PDSWSN,11           CHAR COUNT OVER 11 MEANS DIRECTORY   37600000
         BH    DSF2                (IE NAMELESS SAVE OF CLEAR WS)       37760000
         CLC   ZCONT,PDSWSN                                             37920000
         BE    WSNF2               CONTINUE IS NOT PART OF QUOTA        38080000
         LA    7,1                                                      38240000
         BAL   LKR,ADJQOT          INCREASE COUNT OF SAVED WORKSPACES   38400000
         DC    AL2(0)                                                   38560000
WSNF3    BAL   15,GETRKS                                                38720000
         ST    3,PSLINK            INSERT IN LIST FOR THIS LIBRARY.     38880000
         B     DSEXIT                                                   39040000
WSNF2    CLC   PUBPRI,PDSLIB       NO )SAVE OF CONTINUE IN PUBLIC LIB   39200000
         BL    WSNF3                                                    39360000
         B     ILSAVE              REJECT SAVE OF WS NAMED CONTINUE     39520000
         DROP  4                                                        39680000
ZCONT    DC    0XL9'00'            ESTABLISH LENGTH ATTRIBUTE           39840000
         DC    X'08'               COUNT                                40000000
ZCONT1   ZTEXT 'CONTINUE'                                               40160000
*                                                                       40320000
ILSAVR   TYO   ILSVR1             A LIBRARY IS FULL                     40480000
         MVI   ASDIRCHG,2          SEARCH FAILURE                  DASD 40640000
         B     DSEXIT                                                   40800000
ILSVR1   DC    Y(ILSVR2+1)                                              40960000
ILSVR2   ZTEXT 'NOT SAVED, WS QUOTA USED UP'                            41120000
         ZEND                                                           41280000
*                                                                       41440000
*                                                                       41600000
*        ADJUST SAVED WORKSPACE QUOTA FOR )SAVE, )DROP                  41760000
*        R0 = LIB NUMBER OF CREDITEE                                    41920000
*        R7 IS INCREMENT OR DECREMENT FOR WSA                           42080000
*        0(LKR) IS HALFWORD GLITCH TO LET )ADD CHANGE QUOTA, NOT ACTUAL 42240000
*        )SAVE EXITS TO ILSAVR ON WS QUOTA USED UP                      42400000
*        IF MAN CREDITED WITH SAVE, DROP IS SIGNED ON, ADJUST PTWSA.    42560000
*        IF MAN CREDITED WITH SAVE, DROP IS IN THIS DIRECTORY,          42720000
*        ADJUST MANWSA.  ONE OR BOTH OF THE ABOVE WILL OCCUR.           42880000
*        IF NOT IN THIS DIRECTORY, TELL ASUP TO READ OTHER DIRECTORY.   43040000
ADJQOT   ST    0,DIRSMAN           SAVE CREDITEE FOR ASUP DIR READ      43200000
         XC    DIRSWSQ(4),DIRSWSQ  CLEAR INCREMENT FIELDS          3591 43360000
         L     2,=A(SUPPARS)       SEE IF THIS GUY IS SIGNED ON    2230 43520000
         LA    2,PTBXLE-SUPPARD(2) R2 POINTS TO PTBXLE             2230 43680000
         L     3,8(2)              NOT ENOUGH REGISTERS AROUND FOR BXLE 43840000
PTLOC1   TM    IOB1-PERTERM(3),NSIGNM                                   44000000
         BO    PTLOC2                                                   44160000
         C     0,PTMAN-PERTERM(3)                                       44320000
         BE    ADJQ4               FOUND HIM                            44480000
PTLOC2   A     3,0(2)                                                   44640000
         C     3,4(2)                                                   44800000
         BNH   PTLOC1                                                   44960000
         B     ADJQ2               NOT FOUND                            45120000
ADJQ4    LR    6,7                 SIGNED ON.  ADJUST PERTERM WS INFO   45280000
         LH    1,0(LKR)            WE MAY HIT QUOTA OR ACTUAL           45440000
         AH    6,PTWSA-PERTERM(3,1)                                     45600000
         BNM   *+6                 DON'T ALLOW NEGATIVE QUOTA      3591 45760000
         SR    6,6                                                 3591 45920000
         CH    6,PTWSQ-PERTERM(3)  FOR )SAVE, CHECK RATION EXCEEDED     46080000
         BNH   ADJQ1               OK                                   46240000
         CLI   SDOP,XXSAVE         DON'T PARALYZE HIM ON )DROP          46400000
         BE    ILSAVR                                                   46560000
ADJQ1    SVRAPE                                                         46720000
         STH   6,PTWSA-PERTERM(3,1)                                     46880000
ADJQ2    L     1,DIRSMAN                                                47040000
         SR    0,0                 NOW SEE IF CREDITEE IS IN THIS DIR.  47200000
         L     2,=A(KMANHASH)                                           47360000
         D     0,0(2)                                                   47520000
         MVI   DIRCHG,3            ASSUME NOT                           47680000
         C     0,WFLMAN                                                 47840000
         L     0,DIRSMAN                                                48000000
         BNE   ADJQ5               NOT IN THIS DIRECTORY           3591 48160000
         MVI   DIRCHG,1            ONLY ONE DIRECTORY REWRITE           48320000
         L     2,LIBENDMK                                               48480000
         L     1,MANSTAR                                                48640000
         AR    1,MR                                                     48800000
LOC8A    C     0,0(1)                                                   48960000
         BE    LOC8B                                                    49120000
         C     2,0(1)                                                   49280000
         LA    1,MANENTL(1)                                             49440000
         BNE   LOC8A                                                    49600000
         B     2(LKR)              NOT FOUND.  HE'S BEEN DELETED.       49760000
LOC8B    LH    2,0(LKR)            THIS USUALLY DUPLICATES PERTERM      49920000
         AH    7,MANWSA-PERLIB(1,2)                                     50080000
         BNM   *+6                 DON'T ALLOW NEGATIVE QUOTA      3591 50240000
         SR    7,7                                                 3591 50400000
         CH    7,MANWSQ-PERLIB(1)  CALCULATION ABOVE                    50560000
         BNH   ADJQ3                                                    50720000
         CLI   SDOP,XXSAVE                                              50880000
         BE    ILSAVR                                                   51040000
ADJQ3    STH   7,MANWSA-PERLIB(1,2)                                     51200000
         B     2(LKR)                                                   51360000
*        PUT INCREMENT TO QUOTA OR ACTUAL INTO APPROPRIATE         3591 51520000
*        HALFWORD IN DIRSWSQ.  APLSUP WILL LOOK AT DIRSWSQ.        3591 51680000
ADJQ5    LH    1,0(LKR)            =0 FOR ACTUAL, =-2 FOR QUOTA    3591 51840000
         STH   7,DIRSWSQ+2(1)                                      3591 52000000
         B     2(LKR)              RETURN TO CALLER                3591 52160000
*                                                                       52320000
*                                                                       52480000
*        SUBROUTINE TO LOCATE BLOCK OF TRACKS ON DISK                   52640000
GETRKS   STM   0,5,GETTEM          PRESERVE R0,R1,R4,R5                 52800000
         LH    1,PDSTCNT-1                                              52960000
         BCTR  1,0                                                      53120000
         SLL   1,2                                                      53280000
*        SALVAGED BLOCKS ARE RECORDED IN LINKED LISTS.  A DIFFERENT     53440000
*        LIST IS USED FOR EACH SIZE BLOCK.                              53600000
*        LIST HEADS ARE IN VECTOR STARTING ATSALVHED.                   53760000
         LA    2,SALVHED(1)                                             53920000
         CLC   0(4,2),ZERO                                              54080000
         BE    EWS2               LIST IS EMPTY                         54240000
EWS3     L     3,SALVHED(1)                                             54400000
         AR    3,MR                                                     54560000
         USING PERSAVW,3                                                54720000
         L     2,PSLINK            REMOVE TOP BLOCK                     54880000
         ST    2,SALVHED(1)                                             55040000
EWS6     MVC   PSMAN,GETTEM        REMEMBER SAVER                       55200000
         MVC   PSNAME,PDSWSN                                            55360000
         MVC   PSPASS,PDSPASS      PASSWORD                             55520000
         MVC   PSLINK,ZERO                                              55680000
         LM    0,1,GETTEM                                               55840000
         LM    4,5,GETTEM+16                                            56000000
LO       EQU   OBUF-WFLLIB         LABEL OFFSET                         56160000
*        NOW SETUP NEW WS LABEL FOR APLSUP                              56320000
MKFLAB   MVC   WFLLIB+LO(16),PDSLIB & WSNAME                            56480000
         MVC   WFLMAN+LO(12),PSMAN & PSPASS                             56640000
         MVC   WFLDATE+LO,ZSYMDATE                                      56800000
         MVC   WFLTIME+LO,WFLTIME   TIMESTAMP WS                        56960000
         L     0,PSCYL             PARAMETER TO APLSUP             DASD 57120000
         MVC   ASDIRCHG,DIRCHG     DIRECTORY REWRITE CODE          DASD 57280000
         MVC   OUT2,PSFILE                                              57440000
         DROP  3                                                        57600000
         SR    3,MR                                                     57760000
         BR    15                                                       57920000
*        NO SALVAGED BLOCK OF EXACT SIZE EXISTS                         58080000
*        TRY FREE AREA ON DISK PACK                                     58240000
EWS2     L     3,DSNXTF                                                 58400000
         LA    2,PSWL(3)           FIRST MAKE SURE THERE'S ROOM IN      58560000
         C     2,MANSTAR           DIRECTORY FOR NEW PERSAVW            58720000
         BNL   EWS7                                                     58880000
*        SELECT A FILE TO SAVE THIS WORKSPACE ON                        59040000
*        LIB EXTENT IS FULL IF CFREDSK IS LARGER THAN EXTUP.       5981 59200000
*        R3    IS MAX NUMBER OF FREE TRACKS SO FAR.                5981 59360000
*        R5    IS NUMBER OF FREE TRACKS IN EXTENT R2.              5981 59520000
*        R8  IS ((EXTUP-CFREDSK) IOTA MAX/EXTUP-CFREDSK)  (/1/)         59680000
         LM    0,2,CDCBXLE                                              59840000
         SR    3,3                                                      60000000
MAXS1    SR    5,5                 IF END-CYL MINUS FR-CYL IS MINUS5981 60160000
         LH    4,EXTUP-CDCPARS(2)  END-CYL MINUS FREE-CYL          5981 60320000
         SH    4,CFREDSK-CDCPARS(2)                                5981 60480000
         BM    MAXS4               ONLY IF EXTENT IS FULL          5981 60640000
         LH    5,2+EXTUP-CDCPARS(2) END-HEAD MINUS FREE-HEAD       5981 60800000
         SH    5,2+CFREDSK-CDCPARS(2)                              5981 60960000
         BNM   MAXS3               BRANCH IF HEAD DIFF NOT MINUS   5981 61120000
         LTR   4,4                                                 5981 61280000
         BZ    MAXS4               BR IF EXTENT IS FULL            5981 61440000
         BCTR  4,0                 IF MINUS, DECR CYL DIFF         5981 61600000
         AH    5,HMAX-CDCPARS(2)   AND GET NO. TRKS MINUS 1        5981 61760000
MAXS3    MH    4,CCADJ-CDCPARS+2(2) MULT CYL BY MINUS TRKS/CYL     5981 61920000
         LPR   4,4                                                 5981 62080000
MAXS4    LA    5,1(4,5)            GET TOTAL FREE TRACKS           5981 62240000
         CR    3,5                                                      62400000
         BH    MAXS2                                                    62560000
         LR    3,5                 NEW MAX FREE TRACKS             5981 62720000
         LR    8,2                                                      62880000
MAXS2    BXLE  2,0,MAXS1                                                63040000
         L     1,CFREDSK                                                63200000
         AH    1,PDSTCNT-1                                              63360000
*        FREEDSK  IS IN FORMAT  CCHH                               DASD 63520000
EWS1     EX    1,EWS5              SEE IF WE ARE BEYOND MAX HEAD        63680000
         BH    EWS9                                                     63840000
         A     1,CCADJ             INCREMENT CYLINDER, RESET HEAD       64000000
         B     EWS1                                                     64160000
EWS9     CH    3,PDSTCNT-1         TRKS AVAILABLE VS.TRKS NEEDED   5981 64320000
         BL    EWS4                NO ROOM IN FREE AREA            5981 64480000
         L     0,CFREDSK           FIRST FREE TRACK                     64640000
         SVRAPE                  , CFREDSK IS IN PROTECTED STORAGE      64800000
         ST    1,CFREDSK                                                64960000
         L     3,DSNXTF                                                 65120000
         LA    2,PSWL(3)                                                65280000
         ST    2,DSNXTF                                                 65440000
         AR    3,MR                                                     65600000
         USING PERSAVW,3                                                65760000
         ST    0,PSCYL             CCHH                            DASD 65920000
         MVC   PSLEN,PDSTCNT      NUMBER OF TRACKS                      66080000
         S     8,ADPAR                                                  66240000
         STH   8,PSFILE            FOR APLSUP AND UTILITY               66400000
         B     EWS6                                                     66560000
EWS7     TYO   ADDF1                                                    66720000
         B     EWS8                                                     66880000
*        NO FREE STORAGE FOUND BY SPACE LOCATOR                         67040000
EWS4     TYO   MESS1                                                    67200000
EWS8     EQU   *                                                        67360000
         MVI   ASDIRCHG,2          INDICATE SEARCH FAILURE         DASD 67520000
         B     DSEXIT                                                   67680000
EWS5     CLI   HMAX+1,0            A DIRTY TRICK                        67840000
         DROP  8                                                        68000000
MESS1    DC    Y(MESS1L+1)                                              68160000
MESS1L   ZTEXT 'NO SPACE'                                               68320000
         ZEND                                                           68480000
*                                                                       68640000
*              CHECK THAT USER IS ALLOWED ACCESS TO THIS LIBRARY        68800000
*              R0 = LIBRARY NUMBER IN QUESTION                          68960000
*              ON EXIT, CC = 1 IF PUBLIC LIB, 0 OR 3 OTHERWISE          69120000
*                                                                       69280000
PROTCHK  C     0,PUBPRI            PUBLIC LIB ALWAYS OKAY               69440000
         BCR   4,LKR  BL                                                69600000
PROTCH2  C     0,PTMAN             IF NOT PUBLIC, MUST MATCH            69760000
         BCR   8,LKR               OR BE PRIVILEGED TERM                69920000
         TM    IOB1,PRIVBIT                                             70080000
         BCR   1,LKR               TERMINAL IS PRIVILEGED               70240000
*        AND / (SDOP=XXSAVE), (LIBNUMC GT 1000), LIBNUMC NE PTMAN       70400000
ILSAVE   TYO   ILSV1                                                    70560000
         CLI   SDOP,XXLIB          LIB COMMAND HAS SPECIAL TERMINATION  70720000
         BE    PRLIBZ                                                   70880000
SDREJ    MVI   ASDIRCHG,2          REJECT CODE                     DASD 71040000
         B     DSEXIT                                                   71200000
DSIRMSG  EQU   *                                                        71360000
ILSV1    DC    Y(ILSV2+1)                                               71520000
ILSV2    ZTEXT 'IMPROPER LIBRARY REFERENCE'                             71680000
         ZEND                                                           71840000
WSNFN    TYO   WNOTF1                                                   72000000
         B     SDREJ                                                    72160000
WNOTF1   DC    Y(WNOTF2+1)                                              72320000
WNOTF2   ZTEXT 'WS NOT FOUND'                                           72480000
         ZEND                                                           72640000
         DROP  3                                                        72800000
*        ADD NEW LIBRARY OR MAN NUMBER                                  72960000
*        LIBNUM NOT FOUND IN ADD OPERATION                              73120000
ADDNF    L     1,MANSTAR                                                73280000
         SH    1,=Y(MANENTL)                                            73440000
         CL    1,DSNXTF            MAKE CERTAIN SPACE EXITS             73600000
         BNH   ADDFULL             NO ROOM                              73760000
         ST    1,MANSTAR                                                73920000
         AR    1,MR                NEW MAN AT FRONT OF TABLE            74080000
         USING PERLIB,1                                                 74240000
         ST    0,LIBNUM                                                 74400000
         C     0,PUBPRI            )ADD 1000 IS ILLEGAL                 74560000
         BE    ILSAVE                                                   74720000
         MVC   LIBLINK(MANENTL-4),NEWMAN  INITIALIZE NEW MAN ENTRY      74880000
*        LIBRARY NUMBER FOUND ON ADD                                    75040000
ADDFND   MVC   HISNAME,PDSWSN      FOR PRINTING AT SIGNON               75200000
         LH    5,PDSCPUL           CPU TIME LIMIT                       75360000
         LTR   5,5                                                      75520000
         BZ    *+8                 ZERO MEANS DON'T CHANGE              75680000
         STH   5,SRALIM                                                 75840000
         DROP  1                                                        76000000
         LH    7,PDSWSQI           INCREMENT HIS SAVE QUOTA             76160000
         BAL   LKR,ADJQOT                                               76320000
         DC    AL2(MANWSQ-MANWSA)  MAKE ADJQOT CHANGE QUOTA             76480000
         B     SETPASS                                                  76640000
ADDFULL  TYO   ADDF1                                                    76800000
         MVI   ASDIRCHG,2          REJECT CODE                     DASD 76960000
         B     DSEXIT                                                   77120000
ADDF1    DC    Y(ADDF2+1)                                               77280000
ADDF2    ZTEXT 'LIBRARY TABLE FULL'                                     77440000
         ZEND                                                           77600000
*                                                                       77760000
*        PRINT CONTENTS OF A LIBRARY                                    77920000
*                                                                       78080000
         USING PERSAVW,4                                                78240000
PRLIB    BAL   15,PROTCHK                                               78400000
PRLIBA   CLC   PSLINK,ZERO                                              78560000
         BE    PRLIBZ              END OF LIBRARY PRINT                 78720000
         L     4,PSLINK                                                 78880000
         LA    1,PSNAME            M RELATIVE ADDRESS                   79040000
         ICALL SQUIRTM                                                  79200000
         ICALL LOUT                                                     79360000
         AR    4,MR                MAKE R4 ABSOLUTE                     79520000
         B     PRLIBA                                                   79680000
PRLIBZ   SVCC  YYLIBZ                                                   79840000
         DROP  4                                                        80000000
DSEXIT   ST    0,OUT1              MAIN OUTPUT PARAMETER                80160000
         TM    ASDIRCHG,1          DIRECTORY REWRITE BIT           DASD 80320000
         BZ    DSEXZ                                                    80480000
         STM   0,3,GETTEM                                               80640000
*        UPDATE FREEDSK TABLE IN THIS DIRECTORY                         80800000
UPDFR1   LM    0,2,CDCBXLE                                              80960000
         LA    3,FREEDSK                                                81120000
UPDFR2   MVC   0(4,3),CFREDSK-CDCPARS(2)                                81280000
         LA    3,4(3)                                                   81440000
         BXLE  2,0,UPDFR2          NEXT LIBRARY                         81600000
         MVC   WFLDATE,ZSYMDATE    INDICATE WHEN FREEDSK WAS UPDATED    81760000
         LM    0,3,GETTEM                                               81920000
*        R0 CONTAINS DIRSRES IN CCHH FORMAT                        DASD 82080000
DSEXZ    SVCC  YYEOS                                                    82240000
*                                                                       82400000
         USING PERLIB,1                                                 82560000
*              DELETE USER AND HIS WORKSPACES FROM SYSTEM               82720000
*                                                                       82880000
*        DELETE USER FROM MAN TABLE AND ADJUST MANSTAR                  83040000
DELUS    L     2,MANSTAR                                                83200000
         AR    2,MR                                                     83360000
         L     0,LIBLINK           POINTER TO SAVED WS LIST             83520000
         MVC   0(MANENTL,1),0(2)   MOVE FIRST ENTRY TO DELETED POS      83680000
         SR    2,MR                GIVING OLD MANSTAR                   83840000
         LA    2,MANENTL(2)                                             84000000
         ST    2,MANSTAR           SVI IS SVI+MANENTL                   84160000
         BALR  LKR,0               SET RETURN POINT OF DSDRSUB          84320000
         LR    4,0                                                      84480000
         L     0,PSLINK-PERSAVW(4,MR)                                   84640000
         BXH   4,MR,DSDRSUB        UNLINK PERSAVW IF IT EXISTS          84800000
         B     LOCK2                                                    84960000
*                                                                       85120000
UNLKMK   NI    PLMISC,255-LIBLOCK                                       85280000
         B     LOCK2                                                    85440000
LOCKMK   OI    PLMISC,LIBLOCK                                           85600000
LOCK2    MVI   ASDIRCHG,1          FORCE DIRECTORY REWRITE         DASD 85760000
         SR    0,0                                                 DASD 85920000
         B     DSEXIT                                                   86080000
NEWPASS  MVC   SOPASS,PDSPASS      CHANGE SIGNON PASSWORD               86240000
         B     LOCK2                                                    86400000
         DROP  1                                                        86560000
*                                                                       86720000
         DS    0F                                                       86880000
LIBENDMK DC    F'-1'  SEARCH TERMINATION LIB OR MAN NUMBER              87040000
PUBPRI   DC    F'1000'             PUBLIC LIB NUM IS LESS THAN PUBPRI   87200000
ZERO     DC    F'0'                                                     87360000
*                                                                       87520000
         ENTRY ZSYMDATE                                                 87680000
ZSYMDATE DC    D'0'                                                     87840000
         ENTRY CDCBXLE             FOR TRANSFER VECTOR                  88000000
CDCBXLE  DC    A(CDCL,LIBPZ,LIBPARS)                                    88160000
ADPAR    EQU   CDCBXLE+8                                                88320000
SDTAB    DC    0F'0'               TABLE OF SD OPS                      88480000
NOWS     EQU   X'80'               SKIP SEARCH FOR WS NAME              88640000
NOLBM    EQU   X'40'               'WS NOT FOUND' IF LIB NOT FOUND      88800000
ADDNL    EQU   X'20'               NON DISASTER IF LIB NOT FOUND        88960000
DROP     SDPAR NOLBM,DSDROP                                             89120000
SAVE     SDPAR 0,DSSAVE                                                 89280000
LOAD     SDPAR NOLBM,DSLOAD                                             89440000
COPY     SDPAR NOLBM,DSLOAD                                             89600000
ADD      SDPAR NOWS+NOLBM+ADDNL,ADDFND                                  89760000
LIB      SDPAR NOWS,PRLIB                                               89920000
OFF      SDPAR NOWS,DSOFF                                               90080000
DEL      SDPAR NOWS,DELUS                                               90240000
LOCK     SDPAR NOWS,LOCKMK                                              90400000
UNLK     SDPAR NOWS,UNLKMK                                              90560000
PASS     SDPAR NOWS,NEWPASS                                             90720000
         ORG                                                            90880000
*        NEWMAN GIVES INITIAL VALUES OF MAN ENTRY                       91040000
NEWMAN   DC    F'0'                LIBLINK                              91200000
         DC    2H'0'               MANWSQ, MANWSA                       91360000
         DC    2F'0'               CUMCON,CUMCOM                        91520000
         DC    12X'00'             HISNAME                              91680000
         DC    8X'00'              SOPASS                               91840000
         DC    X'8000'             SRALIM                               92000000
         DC    X'0000'             PLMISC                               92160000
         DC    2F'0'               FUTURE ACCOUNTING                    92320000
*        END OF NEW MAN                                                 92480000
         LTORG                                                          92640000
SDOP     EQU   PDSOP                                                    92800000
*                                                                       92960000
*        SPECIAL DISK PARAMETER AREA                                    93120000
*        LAYOUT IS PDSDDDD                                              93280000
         ENTRY SDPAR                                                    93440000
SDPAR    DS    0D,XL(PDSLEN)       COMMON PARAMETERS                    93600000
         ENTRY COPYID                                                   93760000
COPYID   DS    CL(L'PDSID)                                              93920000
         COPY  CDCPARS                                                  94080000
PERCORE  DSECT                                                          94240000
PCQUONT  DS    H                                                        94400000
PCADDR   DS    AL3                                                      94560000
PCTERM   EQU   *-1                                                      94720000
         DS    AL3                                                      94880000
         END                                                            95040000
./  ADD    NAME=APLSDTRA
DTRA     TITLE 'D Y A D I C   T R A N S P O S E               05/11/70' 00480000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00960000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01440000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01920000
EXTRAN   CSECT                                                          02400000
         PRINT OFF       APLDEFN, OPSECT                                03360000
         COPY  APLDEFN                                                  03840000
         COPY  OPSECT                                                   04320000
         TITLE 'D Y A D I C   T R A N S P O S E               05/11/70' 04800000
         PRINT ON,NOGEN                                                 05280000
         EXTRN ERROR                                                    05760000
         EXTRN FETCH                                                    06240000
         EXTRN FETCHINT                                                 06720000
         EXTRN STORE                                                    07200000
         EXTRN OPSPACE                                                  07680000
SCRATCH DSECT                                                           08160000
         DS    2F                                                       08640000
RHOR     DS    F                                                        09120000
SINCR    DS    F                                                        09600000
RX       DS    F                                                        10080000
EXTRAN   CSECT                                                          10560000
*                                                                       11040000
*                                                                       11520000
*        DYADIC TRANSPOSE                                               12000000
*                                                                       12480000
*        R = P PHI S                                                    12960000
*                                                                       13440000
*        TRANSPOSE OF S.  R(;/I)=S(;/I(P))                              13920000
*                                                                       14400000
*        RESTRICTIONS --                                                14880000
*             (RHO P) = RHO RHO S                                       15360000
*             P IS DENSE                                                15840000
*                                                                       16320000
*                                                                       16800000
SCR      EQU 7                                                          17280000
         USING EXTRAN,9                                                 17760000
         USING OPSECT-16,LR                                             18240000
         USING SCRATCH,SCR                                              18720000
RRR      EQU   BINOSAVE                                                 19200000
*   SAVE LINK & CHECK COMPATIBILITY                                     19680000
         ST    LKR,REGSAV                                               20160000
         CLC   LHRANK+2(2),=H'8'   P MUST BE VECTOR OR SCALAR           20640000
         BL    DOMOK                                                    21120000
         LA    1,ERANK                                                  21600000
         ICALL ERROR                                                    22080000
DOMOK    L     1,LHXRHO                                                 22560000
         SLA   1,2                                                      23040000
         C     1,RHRANK                                                 23520000
         BE    XRHOOK              (RHO P) = RHO RHO S                  24000000
         LA 1,ELENGTH                                                   24480000
         ICALL ERROR                                                    24960000
*   GET SPACE FOR SCRATCH VECTORS                                       25440000
XRHOOK   EQU *                                                          25920000
         MVC   LCFTYPE,LHTYPE      SET UP FETCH ARGUMENTS               26400000
         MVC   RCFTYPE,RHTYPE                                           26880000
         SR    2,2                                                      27360000
         LA    3,2                                                      27840000
         L     10,=A(OPSPACE)                                           28320000
         BALR  LKR,10                                                   28800000
         LA    SCR,M(1)            R7: ABSOLUTE PTR TO SCRATCH          29280000
         L     2,INCR              INCREMENT INCR BECAUSE OF EXTRA      29760000
         LA    2,4(2)              WORD IN EXECUTION STACT DUE TO       30240000
         ST    2,INCR              SCRATCH VECTOR                       30720000
*   INITALIZE SCRATCH VECTORS                                           31200000
         L     1,=F'-16'                                                31680000
         SR    2,2                                                      32160000
         SR    3,3                                                      32640000
         SR    4,4                                                      33120000
         L     8,RHRANK                                                 33600000
         SLA   8,2                                                      34080000
FILL     AR    8,1                                                      34560000
         BM    FILLED                                                   35040000
         LA    5,RHOR(8)                                                35520000
         STM   1,4,0(5)                                                 36000000
         B     FILL                                                     36480000
FILLED   ST    1,RRR               INITALIZE RHO RHO R                  36960000
         L     1,LHBASE            FIND ORIGIN OF LH DATA               37440000
         A     1,LHRANK                                                 37920000
         LA    1,MRHO-M(1)                                              38400000
         ST    1,LHORG                                                  38880000
*   COMPUTE RHO R, FIRST SINCR                                          39360000
         LA    5,1                 R5 FOR X/RHO S                       39840000
         L     8,RHRANK            R8 FOR INDEX INTO RHO S              40320000
         LR    2,8                 R2 FOR INDEX INTO P                  40800000
         SRA   2,2                                                      41280000
         A     8,RHBASE            R8 NOW M-RELATIVE                    41760000
RRLOOP   S     8,=F'4'                                                  42240000
         S     2,=F'1'                                                  42720000
         BM    RRDONE                                                   43200000
         LM    3,4,LCFTYPE                                              43680000
         ICALL FETCHINT            GET NEXT ELEMENT OF P                44160000
         LR    1,0                                                      44640000
         S     1,IORIGIN           ADJUST P(I)                          45120000
         CL    1,RHRANK            MUST BE BETWEEN 0 AND REASONABLE     45600000
         BNL   PNOTDENS            UPPER LIMIT                          46080000
         SLA   1,4                 MAKE IT A 4 WORD POINTER.            46560000
         C     1,RRR                UPDATE RHO RHO R, WHICH IS ALWAYS   47040000
         BNH   RRRNCH               16 TOO LOW & HAS 16 FACTOR RATHER   47520000
         ST    1,RRR                THAN 4.                             48000000
RRRNCH   L     10,SINCR(1)                                              48480000
         AR    10,5                                                     48960000
         ST    10,SINCR(1)                                              49440000
         L     4,MRHO(8)           LOAD RHO S                           49920000
         CL    4,RHOR(1)              COMPARE VS RHO R                  50400000
         BNL   RRNCH                                                    50880000
         ST    4,RHOR(1)           STORE IF SMALLER                     51360000
RRNCH    MR    4,4                 MAKE NEW PRODUCT                     51840000
         B     RRLOOP                                                   52320000
*   CALCULATE SPACE NEEDED, FORM REAL SINCR, CHECK THAT P IS DENSE      52800000
RRDONE   EQU *                                                          53280000
         L     6,RRR               R6: INDEX INTO RHO R, SINCR          53760000
         SR    8,8                 R8: +/SINCR X RHO R - 1              54240000
         LA    1,1                 R1: X/RHO R                          54720000
         LA    3,16                R3: INDEX DECREMENT VALUE            55200000
         LTR   2,6                 R2: SAVE RHO RHO R FOR LATER &       55680000
*                                         SET CC FOR NULL CASE          56160000
NEXTRHOR BM    ALLSET                                                   56640000
         L     5,RHOR(6)           R5: (RHO R)(I)                       57120000
         LTR   5,5                                                      57600000
         BC    10,DENS                                                  58080000
PNOTDENS LA    1,ERANGE                                                 58560000
         ICALL ERROR                                                    59040000
DENS     MR    0,5                 FORM NEW X RHO R                     59520000
         L     4,SINCR(6)          GET 2 COPIES SINCR(I)                60000000
         LR    10,4                                                     60480000
         SR    10,8                DECREMENT SINCR BY SUM               60960000
         ST    10,SINCR(6)                                              61440000
         BCTR  5,0                 USE OLD SINCR TO COMPUTE             61920000
         MR    4,4                      SUM = SUM + SINCR X RHOR - 1    62400000
         AR    8,5                                                      62880000
         SR    6,3                                                      63360000
         B     NEXTRHOR                                                 63840000
*   NOW TO RESERVE SPACE FOR R.  R1 COINCIDENTALLY ALREADY              64320000
*        CONTAINS THE RIGHT THING.  R2 IS CLOSE                         64800000
ALLSET   EQU   *                                                        65280000
         ST    1,RXRHO                                                  65760000
         AR    2,3                                                      66240000
         SRA   2,2                                                      66720000
         LR    4,2                 R4: SAVE RESRANK MOMENTARILY         67200000
         L     3,RHTYPE                                                 67680000
         LR    5,3                 R5: SAVE TYPE FOR THE NONCE          68160000
         L     10,=A(OPSPACE)                                           68640000
         BALR  LKR,10                                                   69120000
*   SPACE RESERVED.  CONSTRUCT RESULT DESCRIPTOR                        69600000
         STH   4,MRANK(1)          R4: INDEX FOR RHO R DESTINATION      70080000
         STC   5,MTYPE(1)          R1: M-RELATIVE PTR TO S              70560000
         LA    0,MRHO-M(4,1)                                            71040000
         ST    0,RESORG                                                 71520000
         L     7,SVI               R7: SVI                              72000000
         L     7,M+8(7)            R7: M-RELATIVE PTR TO SCRATCH        72480000
         LA    10,0(7)             MASK AND SAVE BECAUSE CAN'T HAVE     72960000
*                                      ABSOLUTE POINTER IN INNER LOOP   73440000
         AR    7,MR                R7  IS ABSOLUTE PTR TO SCRATCH       73920000
         LA    1,M(1)              R1: ABSOLUTE PTR TO S                74400000
         L     6,RRR               R6: INDEX FOR RHO R IN SCRATCH       74880000
MOVERHOR S     4,=F'4'                                                  75360000
         BM    MOVED                                                    75840000
         L     8,RHOR(6)                                                76320000
         ST    8,MRHO-M(4,1)                                            76800000
         A     6,=F'-16'                                                77280000
         B     MOVERHOR                                                 77760000
MOVED    EQU   *                                                        78240000
         L     1,RHBASE            SET UP ORIGIN OF S'S DATA            78720000
         A     1,RHRANK                                                 79200000
         LA    1,MRHO-M(1)                                              79680000
         ST    1,RHORG                                                  80160000
*   EFFECT TRANSFER FROM S TO R                                         80640000
         L     0,RXRHO                                                  81120000
         LTR   0,0                                                      81600000
         BZ    RETURN                                                   82080000
         LR    3,5                 R3: ALWAYS TYPE                      82560000
         SR    5,5                 R5: I, INDEX OF R                    83040000
         SR    6,6                 R6: J, INDEX OF S                    83520000
         L     7,RRR               COMPUTE M-RELATIVE START VALUE       84000000
         AR    7,10                FOR K.  STOP VALUE IS IN R10.        84480000
         ST    7,RRR               RRR IS NOW SCRATCH+RRR, M-RELATIVE   84960000
TRANSFER LR    2,6                                                      85440000
         L     4,RHORG                                                  85920000
         ICALL FETCH                                                    86400000
         LR    2,5                                                      86880000
         L     4,RESORG                                                 87360000
         ICALL STORE                                                    87840000
         LA    5,1(5)              INCREMENT I                          88320000
         L     7,RRR               R7: SCRATCH(K), M-RELATIVE           88800000
         QUEND                                                          89280000
STEP     CR    7,10                ARE WE OFF LEFT END OF RX --         89760000
         BL    RETURN              YES.  QUIT.                          90240000
         L     8,RX(MR)            INCREMENT RX(K) UP TO BUT NOT        90720000
         LA    8,1(8)                   INCLUDING RR(K)                 91200000
         ST    8,RX(MR)                                                 91680000
         C     8,RHOR(MR)                                               92160000
         BL    NCH                                                      92640000
         SR    8,8                                                      93120000
         ST    8,RX(MR)                                                 93600000
         A     7,=F'-16'                                                94080000
         B     STEP                PROPAGATE CARRY LEFTWARD             94560000
NCH      A     6,SINCR(MR)                                              95040000
         B     TRANSFER                                                 95520000
RETURN   L     7,SVI                                                    96000000
         L     7,M+8(7)                                                 96480000
         MKG   7                                                        96960000
         L     LKR,REGSAV                                               97440000
         BR    LKR                                                      97920000
         END                                                            98400000
./  ADD    NAME=APLSDYIB
DYIB     TITLE 'DYADIC I-BEAM -- MOSTLY PRIV SYSTEM INTERFACE 05/11/70' 00190000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00380000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00570000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00760000
EXCEINTF CSECT                                                          01140000
         EXTRN ERROR                                                    01520000
         EXTRN FETCH                                                    01710000
         EXTRN FETCHINT                                                 01900000
         EXTRN IM                                                       02090000
         EXTRN OPSPACE                                                  02280000
         EXTRN SUPPARS             MAPPED BY SUPPARD DSECT         2230 02470000
         EXTRN WSLEN                                                    02660000
         PRINT OFF            APLDEFN,PERTERM,OPSECT,APLSUPC       2230 02850000
         APLSUPC ,                 MAPS SUPPARS AREA IN APLSUP     2230 03040000
VALCON   EQU   0                   AVOIDS ASM ERROR                2230 03230000
         COPY  APLDEFN                                                  03420000
         COPY PERTERM                                                   03610000
         COPY  OPSECT                                                   03800000
         TITLE 'DYADIC I-BEAM -- MOSTLY PRIV SYSTEM INTERFACE 05/11/70' 03990000
         PRINT ON,NOGEN                                                 04180000
         EJECT                                                          04370000
*                                                                       04560000
*        DYADIC IBEAM.                                                  04750000
*                                                                       04940000
*              LEFT OPERAND SPECIFIES THE FUNCTION TO BE PERFORMED.     05130000
*        RIGHT IS THE APPROPRIATE OPERAND.                              05320000
*                                                                       05510000
*                                                                       05700000
*        FUNCTIONS..                                                    05890000
*                                                                       06080000
*                                                                       06270000
*                                                                       06460000
* ***    0 IBEAM L,A               FETCH DATA IN MAIN MEMORY            06650000
*                                                                       06840000
* ***    1 IBEAM L,A,D             STORE IN MAIN MEMORY                 07030000
*                                                                       07220000
* ***    2 IBEAM L,A               M-RELATIVE FETCH                     07410000
*                                                                       07600000
* ***    3 IBEAM L,A,D             M-RELATIVE STORE                     07790000
*                                                                       07980000
* ***    4 IBEAM P                 BOUNCE USER AT PORT                  08170000
*                                                                       08360000
*        5 IBEAM T                 DELAY FOR TIME INTERVAL              08550000
*                                                                       08740000
*        6 IBEAM Q,V               WSFNS INTERFACE                      08930000
*                                                                       09120000
* ***    7 IBEAM I                 FETCH A COLUMN OF PERTERMS           09310000
*                                                                       09500000
* ***    8 IBEAM L,A,M             'XOR' TO MAIN STORAGE                09690000
*                                                                       09880000
* ***    9 IBEAM L,A,M             'OR' TO MAIN STORAGE                 10070000
*                                                                       10260000
* ***   10 IBEAM L,A,M             'AND' TO MAIN STORAGE                10450000
*                                                                       10640000
* ***   11 IBEAM P                 RESET PORT                           10830000
*                                                                       11020000
* ***   12 IBEAM 0                 SYSTEM SHUTDOWN                      11210000
*                                                                       11400000
*       13 IBEAM Q                 RESERVED                             11590000
*                                                                       11780000
*                                                                       11970000
*              A - STARTING ADDRESS OF DATA                             12160000
*              D - VECTOR OF DATA, FULL WORD INTEGERS                   12350000
*              I - WORD INDEX OF WORD TO BE FETCHED FROM PERTERM        12540000
*              L - LENGTH OF DATA IN BYTES                              12730000
*              M - VECTOR OF MASK, FULL WORD INTEGERS                   12920000
*              P - PORT NUMBER                                          13110000
*              Q - CODE INDICATING SPECIFIC OPERATION                   13300000
*              V - SCALAR INTEGER VALUE                                 13490000
*              Z - Z-SYSMOLS WITH COUNT IN INTEGER FORMAT               13680000
*                                                                       13870000
*                                                                       14060000
*        *** ALLOWED ONLY FROM PRIVILEGED TERMINALS.                    14250000
         EJECT                                                          14440000
EXCEINTF CSECT                                                          14630000
         USING *,9                                                      14820000
         USING OPSECT-16,LR                                             15010000
         SPACE                                                          15200000
         ST    LKR,TEMPRES         SAVE LINK OVER CALLS.                15390000
         LA    8,SYNERR                                                 15580000
*                                                                       15770000
*        NOW DECIDE WHICH FUNCTION TO ENTER.                            15960000
*                                                                       16150000
         L     4,LHBASE            FETCH LEFT OPERAND.                  16340000
         A     4,LHRANK            BASE + RANK                          16530000
         LA    4,MRHO-M(4)         + HEADER LENGTH GIVES DATA POINTER.  16720000
         L     3,LHTYPE            GET THE TYPE.                        16910000
         SR    2,2                 POINTAT FIRST ELEMENT.               17100000
         ICALL FETCHINT            GOT IT.                              17290000
         LR    1,0                 MOVE TO R1                           17480000
         SLL   1,2                 MULTIPLY BY 4 TO GET WORD INDEX.     17670000
         CL    1,FNTABLN           SEE IF IT'S WITHIN BOUNDS.           17860000
         BCR   11,8 BNLR           BRANCH IF NOT                        18050000
         L     5,FNTAB(1)          OTHERWISE, PICK UP ROUTINE ADDRESS.  18240000
         ST    5,CURRES            SAVE THE ADDRESS                     18430000
*                                                                       18810000
*        CHECK FOR A PRIVILEGED TERMINAL                                19000000
*                                                                       19190000
         TM    CURRES,PRIVREQ      SEE IF USER MUST BE PRIVILEGED       19380000
         BZ    CEINT1              IF NOT PICK UP FIRST ARGUMENT        19570000
         L     4,=A(SUPPARS)       PICK UP PERTERM BASE -          2230 19760000
         L     4,PTBASE-SUPPARD(4)  FROM PROTECTED STORAGE.        2230 19950000
         TM    IOB1-PERTERM(4),PRIVBIT SEE IF THIS GUY IS PRIVILEGED    20140000
         BCR   8,8 BZR             NO, SLAP HIS WRIST                   20330000
CEINT1   DS    0H'0'                                                    20520000
*                                                                       20710000
*        FETCH FIRST RIGHT OPERAND INTO REG 7                           20900000
*                                                                       21090000
         L     4,RHBASE            FETCH FIRST RIGHT OPERAND            21280000
         TM    CURRES,IBCHAR       TEST FOR Z-SYMBOLS ON RIGHT          21470000
         BO    CEINT3              YES, GO CHECK TYPE, ET AL            21660000
         A     4,RHRANK            BASE+RANK                            21850000
         LA    4,MRHO-M(4)         + HEADER LENGTH GIVES DATA POINTER   22040000
         L     3,RHTYPE            SPECIFY THE TYPE                     22230000
         SR    2,2                 SPECIFY THE FIRST ELEMENT            22420000
         ICALL FETCHINT                                                 22610000
         LTR   7,0                 SAVE IN REG 7                        22800000
         BM    RNGERR              RANGE ERROR IF NEGATIVE              22990000
*                                                                       23180000
*        FETCH SECOND RIGHT OPERAND (IF NEEDED) INTO REG 6              23370000
*                                                                       23560000
         L     8,RHXRHO            PREPARE FOR RIGHT LENGTH CHECK       23750000
         TM    CURRES,IBARG2       IF NO SECOND ARGUMENT, RT LENGTH     23940000
         BZ    CEINT2              MUST BE ONE                          24130000
         LA    2,1                 OTHERWISE FETCH SECOND ARGUMENT      24320000
         ICALL FETCH               FETCH BECAUSE OUR DEAR FRIEND        24510000
*                                  FETCHINT FUTZED UP REG 3 ON US       24700000
         LR    6,0                                                      24890000
         BCTR  8,0                 RT LENGTH MUST BE TWO                25080000
         TM    CURRES,IBARGN       TEST FOR MORE THAN TWO RT ARGUMENTS  25270000
         BO    *+8                 IF MORE BRANCH                       25460000
CEINT2   BCT   8,LNGTHERR          IF RT LENGTH WRONG, ERROR            25650000
         SR    8,8                 R8=0 NEEDED BY CEAND & CEOR          25840000
*                                                                       26030000
*        IF SECOND RT OPERAND IS M-REL, RANGE CHECK & MAKE ABSOLUTE     26220000
*                                                                       26410000
         TM    CURRES,IBMREL       TEST IF M-REL & RANGE CHECK NEEDED   26600000
         BCR   8,5                 ARGUMENT ALREADY ABSOLUTE            26790000
         L     2,=A(WSLEN)         TEST FOR VALID M-REL ADDR            26980000
         L     2,0(2)              PICK UP WS LENGTH                    27170000
         LA    6,0(6)              CLEAR OUT HIGH ORDER BYTE            27360000
         CR    6,2                                                      27550000
         BH    RNGERR              TOO BIG, ERROR                       27740000
         AR    6,MR                MAKE ADDR ABSOLUTE                   27930000
         BR    5                   GO TO EXECUTION ROUTINE              28120000
*                                                                       28310000
*        RIGHT ARGUMENT IS IN Z-SYMBOLS                                 28500000
*                                                                       28690000
CEINT3   LA    1,M(4)              SIMULATE INDEXED CLI INSTRUCTION     28880000
         CLI   MTYPE-M(1),2        ARGUMENT MUST BE INTEGER             29070000
         BCR   7,8 BNER            NO, SYNTAX ERROR                     29260000
         CLI   MRANK+1-M(1),4      RANK MUST BE VECTOR                  29450000
         BCR   7,8 BNER            NO, SYNTAX ERROR                     29640000
         CLI   MLSORG+4-M(1),0     INTERNAL COUNT MUST BE < 256         29830000
         BCR   7,8 BNER            NO, SYNTAX ERROR                     30020000
         BR    5                   ENTER APPROPRIATE ROUTINE            30210000
         SPACE 2                                                        30400000
SYNERR   LA    1,ESYNTAX           FOR THE HELL OF IT.                  30590000
         ICALL ERROR               FOR THE HELL OF IT.                  30780000
         SPACE 2                                                        30970000
RNGERR   LA    1,ERANGE            OPERAND OUT OF RANGE.                31160000
         ICALL ERROR                                                    31350000
         SPACE                                                          31540000
LNGTHERR LA    1,ELENGTH           LENGTH ERROR                         31730000
         ICALL ERROR                                                    31920000
         EJECT                                                          32110000
*                                                                       32300000
*        0 - LOOK AT ANY WORD IN STORAGE.                               32490000
*        2 - M RELATIVE  FETCH.                                         32680000
*              M-REL ADDR HAS BEEN MADE ABSOLUTE                        32870000
*                                                                       33060000
CEDISP   CL    7,=F'256'           CHECK FOR PROPER LENGTH              33250000
         BH    RNGERR              IF TOO BIG RANGE ERROR               33440000
CERETURN LA    1,3(7)              COMPUTE WORD LENGTH                  33630000
         SRL   1,2                 OF RESULT                            33820000
         LR    4,1                                                      34010000
         LA    2,4                 RANK=VECTOR                          34200000
         LA    3,2                 INTEGER TYPE                         34390000
         L     10,=A(OPSPACE)      GET SPACE                            34580000
         BALR  LKR,10                                                   34770000
         L     2,TPRANK                                                 34960000
         ST    2,MTYPE(1)          RANK OF ONE, INTEGER TYPE            35340000
         ST    4,MRHO(1)           STORE RHO                            35530000
         LA    1,MRHO+4-M(1)       DATA POINTER OF RESULT               35720000
         ST    1,RESORG                                                 35910000
         L     LKR,TEMPRES         PICK UP LINK AND RETURN              36100000
         AR    1,MR                                                     36290000
         LTR   7,7                 IF COUNT IS ZERO RETURN.             36480000
         BCR   8,LKR                                                    36670000
         BCTR  4,0                 ZERO OUT LAST WORD OF                36860000
         SLL   4,2                 RESULT SO THAT WE DONT               37050000
         AR    4,1                 PASS GARBAGE                         37240000
         XC    0(4,4),0(4)                                              37430000
         BCTR  7,0                 FOR EXECUTE INSTRUCTION              37620000
         EX    7,ZAPPER            MOVE DATA                            38000000
         BR    LKR                 RETURN                               38190000
*                                                                       38380000
ZAPPER   MVC   0(*-*,1),0(6)                                            38570000
*                                                                       38760000
*                                                                       38950000
*                                                                       39140000
*                                                                       39330000
*         1 - STORE IN MAIN STORAGE                                     39520000
*         3 - STORE IN M-REL STORAGE                                    39710000
*         8 - XOR TO MAIN STORAGE                                       39900000
*         9 - OR TO MAIN STORAGE                                        40090000
*        10 - AND TO MAIN STORAGE                                       40280000
*                                                                       40470000
*              NOTE.. IF M-REL AND, OR, XOR ARE DESIRED,                40660000
*              ADD ENTRIES TO FNTAB WITH                                40850000
*              IBMREL (& PRIVREQ) BITS.                                 41040000
*                                                                       41230000
*                                                                       41420000
CEXOR    LA    8,CEXORZ-CEORZ(8)                                        41610000
CEOR     LA    8,CEORZ-CEANDZ(8)                                        41800000
CEAND    LA    8,CEANDZ-CESTOREZ(8)                                     41990000
CESTORE  LA    14,(256-NDOPSECT+FACTSAVE+7)/8*8(14)                     42180000
*              EXTEND R13 STACK TO GET 256 BYTE SCRATCH AREA            42370000
*        OPSECT ENTRIES BEYOND FACTSAVE ARE DESTROYED BELOW             42560000
         CL    7,=F'256'           CHECK LENGTH                         42750000
         BH    RNGERR              IF TOO BIG RANGE ERROR               42940000
         LTR   7,7                 TEST  FOR ZERO LENGTH                43130000
         BZ    SVIADJ              IF ZERO, DON'T BOTHER                43320000
         BCTR  7,0                 SET UP FOR EXECUTE INSTRUCTION       43510000
         LA    5,4(7)              GET LENGTH IN WORDS                  43700000
         SRL   5,2                                                      43890000
         LA    2,2                 POINT TO NEXT OPERAND                44080000
         AR    5,2                 TOTAL NUMBER OF RT OPERANDS          44270000
         CL    5,RHXRHO            ARE THERE ENOUGH OPERANDS?           44460000
         BH    LNGTHERR            IF NOT ENOUGH, LENGTH ERROR          44650000
         SR    5,2                 INITIALIZE COUNTER                   44840000
         SR    10,10               INITIALIZE INDEX REG                 45030000
CESTOR1  ICALL FETCH               GET NEXT OPERAND                     45220000
         ST    0,FACTSAVE(10)      SAVE IT IN SCRATCH AREA              45410000
         LA    2,1(2)              BUMP OPERAND POINTER                 45600000
         LA    10,4(10)            BUMP INDEX REGISTER                  45790000
         BCT   5,CESTOR1           EXHAUST OPERANDS                     45980000
         TM    CURRES,IBMREL       TEST FOR M-REL ADDRESS               46170000
         BO    TOCORE              IF SO, BYPASS TEST FOR IN WSS        46360000
         L     1,=A(SUPPARS)       WE REFUSE TO PERMIT ANYONE TO   2230 46550000
         LM    1,2,PCBXLE-SUPPARD+4(1)  DO AN ABS WS PATCH         2230 46740000
         LH    2,PCADDR-PERCORE(2) WITHIN AREA RESERVED FOR WSS.   P042 46930000
         SLL   2,8                                                 P042 47120000
         LA    6,0(6)              CLEAR OUT HIGH BYTE                  47310000
         CR    6,2                                                 P042 47500000
         BL    CESTORE3            BR IF BELOW FIRST WS            P042 47690000
         LH    1,PCADDR-PERCORE(1)                                 P042 47880000
         SLL   1,8                                                 P042 48070000
         L     2,=A(WSLEN)                                         P042 48260000
         A     1,0(2)              POINT TO END OF LAST WS         P042 48450000
         CR    6,1                                                 P042 48640000
         BL    RNGERR              BR IF BELOW END OF LAST WS      P042 48830000
CESTORE3 IC    2,0(6,7)            LAZY HIGH CORE TEST                  49020000
         SVRAPE                                                         49210000
TOCORE   BAL   1,CESTOREX                                               49400000
SVIADJ   L     5,SVI               NOW, PICK UP SVI.                    49590000
         SR    0,0                                                      49780000
         ST    0,M(5)              A 0 WORD MEANS NO RESULT.            49970000
         A     5,=F'-4'            MOVE UP SVI                          50160000
         ST    5,SVI               AND PUT IT BACK.                     50350000
         L     LKR,TEMPRES         RETURN                               50540000
         BR    LKR                                                      50730000
*                                                                       50920000
*        EXECUTED INSTRUCTIONS                                          51110000
*                                                                       51300000
CESTOREX EX    7,CESTOREZ(8)                                            51490000
         BR    1                                                        51680000
CESTOREZ MVC   0(*-*,6),FACTSAVE                                        51870000
CEANDZ   NC    0(*-*,6),FACTSAVE                                        52060000
CEORZ    OC    0(*-*,6),FACTSAVE                                        52250000
CEXORZ   XC    0(*-*,6),FACTSAVE                                        52440000
*                                                                       52630000
*                                                                       52820000
*                                                                       53010000
*                                                                       53200000
*        4 - BOUNCE TERMINAL SPECIFIED BY RIGHT OPERAND.                53390000
*                                                                       53580000
CEBOUN   LR    1,7                 MOVE TO R1 FOR YYBOUN                53770000
         SVCC  YYBOUN              BOUNCE SVC                           53960000
         B     SVIADJ              GO FIX UP STACK.                     54150000
*                                                                       54340000
*                                                                       54530000
*                                                                       54720000
*        5 - VOLUNTARY SUSPENSION.                                      54910000
*        CALLER IS SUSPEMDED FOR TIME SPECIFIED IN RIGHT OPERAND.       55100000
*        UNITS - 300THS OF SECONDS.                                     55290000
*                                                                       55480000
CEDEL    TCOM  DELAY,(7)           DELAY                                55670000
         B     SVIADJ              GO FIX UP STACK.                     55860000
*                                                                       56050000
*                                                                       56240000
*                                                                       56430000
*        11 - RESET PORT                                                56620000
*                                                                       56810000
CERESET  LR    1,7                 MOVE PORT NUMBER TO R1               57000000
         SVCC  YYRSET              RESET SVC                            57190000
         B     SVIADJ              GO FIX UP STACK                      57380000
*                                                                       57570000
*                                                                       57760000
*                                                                       57950000
*        12 - SYSTEM SHUTDOWN                                           58140000
*                                                                       58330000
CESHUT   LTR   0,7                 PASS PARM TO APLSUP             P042 58520000
         BNZ   RNGERR              RANGE ERROR IF RH OPER NOT 0    P042 58710000
         SVCC  YYEOD                    0 = INITIATE SHUTDOWN           58900000
         B     SVIADJ                                                   59090000
*                                                                       71250000
*                                                                       71440000
*                                                                       71630000
*        6 - WSFNS INTERFACE -- RESTRICTED WS PATCH                     71820000
*              A DESIRED LOCATION IS PATCHED AND THE OLD VALUE RETURNED 72010000
*                                                                       72200000
*        CODE  FUNCTION      LOCATION                                   72390000
*                                                                       72580000
*        0     ORIGIN        IORIGIN                                    72770000
*        1     SETLINK       RNUMBER                                    72960000
*        2     DIGITS        OSIGDIG                                    73150000
*        3     WIDTH         OBUFLIM                                    73340000
*        4     FUZZ          CPUTFUZZ+4                                 73530000
*                                                                       73720000
*                                                                       73910000
CEWSFNS  SLL   7,2                 IS WSFNS CODE VALID                  74100000
         CL    7,CEWTABLN                                               74290000
         BNL   SYNERR              NO, CONFUSE HIM WITH SYNTAX ERROR    74480000
         L     8,CEWTABL(7)        LOAD M-REL ADDRESS                   74670000
         SR    3,3                 FIND OUT LENGTH (H OR F) OF SLOT     74860000
         IC    3,CEWTABL(7)                                             75050000
         EX    0,CEWLOAD(3)        PICK UP OLD VALUE TO RETURN          75430000
         C     6,CEWLOW(7)         IS VALUE TOO SMALL                   75620000
         BL    RNGERR              YES, ERROR                           75810000
         C     6,CEWHIGH(7)        IS VALUE TOO BIG                     76000000
         BH    RNGERR              YES, ERROR                           76190000
         EX    0,CEWSAVE(3)        STORE NEW VALUE                      76380000
         ST    5,SAVER-4           SAVE OLD VALUE                       76570000
         LA    6,SAVER-4           PICK UP POINTER TO OLD VALUE         76760000
         LA    7,4                 NUMBER OF BYTES TO BE RETURNED       76950000
         B     CERETURN            RETURN OLD VALUE & EXIT              77140000
         SPACE 2                                                        77330000
CEWLOAD  L     5,M(8)                                                   77520000
         LH    5,M(8)                                                   77710000
CEWSAVE  ST    6,M(8)                                                   77900000
         STH   6,M(8)                                                   78090000
*                                                                       78280000
CEWTABL  DC    0F'0'                                                    78470000
         DC    AL1(0)              0 - ORIGIN                           78660000
         DC    AL3(IORIGIN-M)                                           78850000
         DC    AL1(0)              1 - SETLINK                          79040000
         DC    AL3(RNUMBER-M)                                           79230000
         DC    AL1(0)              2 - DIGITS                           79420000
         DC    AL3(OSIGDIG-M)                                           79610000
         DC    AL1(4)              3 - WIDTH                            79800000
         DC    AL3(OBUFLIM-M)                                           79990000
         DC    AL1(0),AL3(CPUTFUZZ+4-M)                                 80180000
CEWTABLN DC    A(*-CEWTABL)                                             80370000
*                                                                       80560000
*                                                                       80750000
CEWLOW   DC    F'0'                LOW LIMIT - ORIGIN                   80940000
         DC    F'1'                LOW LIMIT - SETLINK                  81130000
         DC    F'1'                LOW LIMIT - DIGITS                   81320000
         DC    F'30'               LOW LIMIT - WIDTH                    81510000
         DC    F'0'                LOW LIMIT - FUZZ                     81700000
*                                                                       81890000
CEWHIGH  DC    F'1'                HIGH LIMIT - ORIGIN                  82080000
         DC    F'2147483646'       HIGH LIMIT - SETLINK                 82270000
         DC    F'16'               HIGH LIMIT - DIGITS                  82460000
         DC    F'130'              HIGH LIMIT - WIDTH                   82650000
         DC    F'2147483647'       HIGH LIMIT - FUZZ                    82840000
*                                                                       83030000
*                                                                       83220000
*                                                                       83410000
*        7 - FETCH A COLUMN OF THE PERTERMS                             83600000
*                                                                       83790000
CEPTERM  LR    0,7                                                      83980000
         N     0,=F'3'             RANGE ERROR IF NOT ON WORD ALIGNMNT  84170000
         BNZ   RNGERR              OTHERWISE R0 = 0 (FOR PERTERM        84360000
         L     4,=A(SUPPARS)       LENGTH CALCULATION              2230 84550000
         LM    4,6,PTBXLE-SUPPARD(4)                               2230 84740000
         LR    1,5                 COMPUTE LENGTH OF PERTERM            84930000
         SR    1,6                                                      85120000
         DR    0,4                                                      85310000
         LA    1,1(1)              MAKE ONE-ORIGIN                      85500000
         LR    8,1                 HOLD ONTO PERTERM LENGTH             85690000
         LA    2,4                 RANK = VECTOR                        85880000
         LA    3,2                 TYPE = INTEGER                       86070000
         L     10,=A(OPSPACE)      GET SPACE FOR RESULTING VECTOR       86260000
         BALR  LKR,10                                                   86450000
         L     2,TPRANK            PLANT HEADER = INTEGER VECTOR        86830000
         ST    2,MTYPE(1)                                               87020000
         ST    8,MRHO(1)           RESULT RHO = LENGTH OF PERTERM       87210000
         LA    2,MRHO+4(1)                                              87400000
         ST    2,RESORG            RESULT POINTER                       87590000
CEPTLOOP L     3,0(6,7)            PICK UP PROPER WORD                  87780000
         ST    3,0(2)              PUT INTO RESULT VECTOR               87970000
         LA    2,4(2)              BUMP UP TO NEXT WORD                 88160000
         BXLE  6,4,CEPTLOOP        LOOP UNTIL ALL MOVED IN              88350000
         L     LKR,TEMPRES         PICK UP RETURN ADDR                  88540000
         BR    LKR                 RETURN                               88730000
CPUTFUZZ EQU   RFUZZ                                                    88920000
*                                                                       89110000
*        CONSTANTS.                                                     89300000
*                                                                       89490000
*        FNTAB FLAG SETTINGS.                                           89680000
IBMREL   EQU   X'80'               OPERAND OT BE M-RELATIVE.            89870000
PRIVREQ  EQU   X'40'               USER MUST BE PRIVILEGED              90060000
IBARG2   EQU   X'20'               RIGHT ARGUMENT 2 REQUIRED            90250000
IBARGN   EQU   X'10'+IBARG2        MORE THAN TWO RT ARGS                90440000
IBCHAR   EQU   X'08'               ARGUMENT IS IN Z-SYMBOLS             90630000
*                                                                       90820000
FNTAB    DC    0F'0'               WORD ALLIGNMENT AREA.                91010000
 DC AL1(PRIVREQ+IBARG2),AL3(CEDISP)              0 - FETCH ABSOLUTE     91200000
 DC AL1(PRIVREQ+IBARGN),AL3(CESTORE)             1 - STORE ABSOLUTE     91390000
 DC AL1(PRIVREQ+IBMREL+IBARG2),AL3(CEDISP)       2 - FETCH M-REL        91580000
 DC AL1(PRIVREQ+IBMREL+IBARGN),AL3(CESTORE)      3 - STORE M-REL        91770000
 DC AL1(PRIVREQ),AL3(CEBOUN)                     4 - BOUNCE             91960000
 DC AL1(0),AL3(CEDEL)                            5 - DELAY              92150000
 DC AL1(IBARG2),AL3(CEWSFNS)                     6 - WSFNS INTERFACE    92340000
 DC AL1(PRIVREQ),AL3(CEPTERM)                    7 - FETCH COL OF PT    92530000
 DC AL1(PRIVREQ+IBARGN),AL3(CEXOR)               8 - XOR TO ABSOLUTE    92720000
 DC AL1(PRIVREQ+IBARGN),AL3(CEOR)                9 - OR TO ABSOLUTE     92910000
 DC AL1(PRIVREQ+IBARGN),AL3(CEAND)              10 - AND TO ABSOLUTE    93100000
 DC AL1(PRIVREQ),AL3(CERESET)                   11 - RESET PORT         93290000
 DC AL1(PRIVREQ),AL3(CESHUT)                    12 - SHUTDOWN           93480000
 DC AL1(0),AL3(SYNERR)                          13 - RESERVED           93670000
FNTABLN  DC    A(*-FNTAB)           MUST FOLLOW TABLE.                  94620000
         SPACE                                                          94810000
LOCIM    DC    A(IM)                                                    95000000
TPRANK   DC    X'02000004'                                              95190000
         LTORG                                                          95380000
*                                                                       95570000
*        ONE COPY PER CORE SLOT                                         95760000
PERCORE  DSECT                                                          95950000
PCQUONT  DS    1H                  QUONT COUNTER                        96140000
PCADDR   DS    AL3                 STARTING ADDRESS OF THIS SLOT        96330000
PCTERM   EQU   *-1                 PERTERM BASE REGISTER                96520000
         DS    AL3                 HIGH ORDER BIT ON MEANS UNASSIGNED   96710000
         DS    0D                                                       96900000
*                                                                       97090000
         END                                                            97280000
./  ADD    NAME=APLSEPSI
EPSI     TITLE 'E P S I L O N                                 05/11/70' 00520000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01040000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01560000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       02080000
         PRINT OFF       APLDEFN, OPSECT                                03120000
EXEPS    CSECT                                                          03640000
         COPY  APLDEFN                                                  04160000
         COPY  OPSECT                                                   04680000
         TITLE 'E P S I L O N                                 05/11/70' 05200000
         PRINT ON,NOGEN                                                 05720000
*                                                                       06240000
*        DYADIC EPSILON                                                 06760000
*                                                                       07280000
*        R = LH EPSI RH                                                 07800000
*                                                                       08320000
*        CHARACTERISTIC OF LH ON RH.                                    08840000
*                                                                       09360000
*        (RHO R) = RHO LH.                                              09880000
*                                                                       10400000
*        R(I) = 1 IFF LH(I) IS CONTAINEDIN RH.                          10920000
*                                                                       11440000
*        LH AND RH RANKS ARBITRARY.                                     11960000
*                                                                       12480000
         SPACE                                                          13000000
EXEPS    CSECT                                                          13520000
         USING *,9                                                      14040000
         USING OPSECT-16,LR                                             14560000
         ST    LKR,REGSAV          SAVE LINK TO THE OUTSIDE WORLD.      15080000
         SPACE                                                          15600000
*                                                                       16120000
*        FIRST, GET SPACE                                               16640000
*                                                                       17160000
         SPACE                                                          17680000
         L     1,LHXRHO            NUMBER OF RESULT COMPNENTS.          18200000
         L     2,LHRANK            PICK UP RESULT RANK.                 18720000
         LA    3,1                 TYPE - BOOLEAN.                      19240000
         L     10,=A(OPSPACE)      GET ENTRY TO COMMON GETSPACE ROUTINE 19760000
         BALR  LKR,10              AND CALL IT.                         20280000
         SPACE                                                          20800000
*                                                                       21320000
*        SET UP HEADER.                                                 21840000
*                                                                       22360000
         SPACE                                                          22880000
         LR    8,1                 MOVE PTR TP R8.                      23400000
         L     2,LHRANK            RESULT RANK.                         23920000
         ST    2,MTYPE(8)          STORED.                              24960000
         LA    2,1                 RESULT TYPE - BOOLEAN.               25480000
         STC   2,MTYPE(8)          STORED.                              26000000
         L     3,LHRANK            SEE IF THERE IS A RANK VECTOR        26520000
         LTR 3,3                                                        27040000
         BZ    RANKIN              BRANCH IF NOT.                       27560000
         LA    1,MRHO(1)           POINT AT RANK VECTOR.                28080000
         L     2,LHBASE                                                 28600000
         LA    2,MRHO(2)           OF RESULT AND LH OPERAND.            29120000
         BCTR  3,0                 MAKE RANK INTO SS COUNT.             29640000
         EX    3,MOVRANK           AND MOVE IN THE RANK.                30160000
         SPACE                                                          30680000
*                                                                       31200000
*        NOW, SET UP FOR EXECUTION.                                     31720000
*                                                                       32240000
RANKIN   L     1,COMTYP            LOOK AT COMPUTE TYPE.                32760000
         S     1,EPS2              -2                                   33280000
         SLL   1,2                 MAKE WORD INDEX,                     33800000
         L     5,CROUT(1)          PICK UP ROUTINE ADDRESS.             34320000
         LA    2,32                                                     34840000
         ST    2,STRSHIFT          BOOLEAN SHIFTER.                     35360000
         A     8,LHRANK                                                 35880000
         LA    8,MRHO-M(8)         RESULT POINTER.                      36400000
         SPACE                                                          36920000
         L     1,LHBASE                                                 37440000
         A     1,LHRANK                                                 37960000
         LA    1,MRHO-M(1)                                              38480000
         ST    1,LHORG                                                  39000000
         L     1,LCTYPE                                                 39520000
         ST    1,LCFTYPE           LEFT IS SET UP.                      40040000
         SPACE                                                          40560000
         L     1,RHBASE                                                 41080000
         A     1,RHRANK                                                 41600000
         LA    1,MRHO-M(1)                                              42120000
         ST    1,RHORG                                                  42640000
         L     1,RCTYPE                                                 43160000
         ST    1,RCFTYPE           RIGHT IS SET UP.                     43680000
         SPACE                                                          44200000
         SR    1,1                                                      44720000
         ST    1,LINDX                                                  45240000
         ST    1,RINDX             FETCH INDICES.                       45760000
         SPACE                                                          46280000
         L     6,RHXRHO                                                 46800000
         L     7,LHXRHO            RESULT COUNT.                        47320000
         SPACE                                                          47840000
         LTR   6,6                                                      48360000
         BZ    ALLZERO             BRANCH IF RH EMPTY.                  48880000
         LTR   7,7                                                      49400000
         BNZ   LOOPS               OR IF LEFT ISN'T.                    49920000
         SPACE                                                          50440000
FINI     L     LKR,REGSAV          OTHERWISE, QUIT.                     50960000
         BR    LKR                                                      51480000
         EJECT                                                          52000000
*                                                                       52520000
*        EPSILON EXECUTION.                                             53040000
*                                                                       53560000
         SPACE                                                          54080000
LOOPS    EQU   *                                                        54600000
         C     5,CROUT+8           SEE IF ONE OPERAND IS CHAR.          55120000
         BE    MIXED               BRANCH IF SO.                        55640000
         SPACE                                                          56160000
OUTER    LM    2,4,LHFETCH         FETCH A LEFT.                        56680000
         ICALL FETCH                                                    57200000
         LA    2,1(2)                                                   57720000
         ST    2,LINDX                                                  58240000
         STM   0,1,DBLHOLD         SAVE IT.                             58760000
         SR    1,1                 INITIALIZE RESULT TO ZERO.           59280000
         ST    1,RINDX                                                  59800000
         ST    1,CURRES                                                 60320000
         L     6,RHXRHO            INNER LOOP COUNT.                    60840000
INNER    LM    2,4,RHFETCH         FETCH A RIGHT.                       61360000
         ICALL FETCH               GOT IT.                              61880000
         QUEND                                                          62400000
         LA    2,1(2)              BUMP INDEX.                          62920000
         ST    2,RINDX                                                  63440000
         BR    5                   COMPARE                              63960000
NOHIT    BCT   6,INNER                                                  64480000
         LM    0,2,GEARSHFT        FALL THROUGH IF BNO HITS.            65000000
HIT      SLDL  0,1                 SHIFT.                               65520000
         BCT   2,NOSTORE           BRANCH IF NOT YET FULL WORD.         66040000
         ST    0,M(8)              OTHERWISE, STORE.                    66560000
         LA    8,4(8)              BUMP RESULT POINTER.                 67080000
         LA    2,32                RESET SHIFT COUNT.                   67600000
NOSTORE  STM   0,2,GEARSHFT                                             68120000
         BCT   7,OUTER             AND LOOP.                            68640000
         SPACE                                                          69160000
*                                                                       69680000
*        FINISHED WHEN WE FALL THROUGH.                                 70200000
         LM    0,2,GEARSHFT        FINAL SHIFT ABD STORE.               70720000
         C     2,EPS32             SEE IF WE JUST DID ONE.              71240000
         BE    FINI                BRANCH IF SO.                        71760000
         SLL   0,0(2)              OTHERWISE, SHIFT -                   72280000
         ST    0,M(8)              AND STORE.                           72800000
         B     FINI                AND WE'RE DONE.                      73320000
         EJECT                                                          73840000
*                                                                       74360000
*        TEST ROUTINES.                                                 74880000
*                                                                       75400000
         SPACE                                                          75920000
FCOMPARE C     0,DBLHOLD           FIXED OR CHARACTER.                  76440000
         BNE   NOHIT               BRANCH IF NOR EQUAL.                 76960000
         LM    0,2,GEARSHFT                                             77480000
         BCTR  1,0                 SET RESULT TO 1.                     78000000
         B     HIT                 AND RETURN                           78520000
         SPACE                                                          79040000
DCOMPARE SW    0,DBLHOLD           FLOATING.                            79560000
         STD   0,DBLSAVE           STORE DIFFERENCE.                    80080000
         CLC   DBLSAVE+1(7),RFUZZ+1 LOOK AT RELATIVE DIFFERENCE.        80600000
         BH    NOHIT                                               3564 81120000
         LM    0,2,GEARSHFT        OTHERWISE, RESULT IS 1.              81640000
         BCTR  1,0                 SET RESULT TO 1.                     82160000
         B     HIT                                                      82680000
         SPACE                                                          83200000
MIXED    L     1,LHTYPE            CHARACTER - LOOK AT TYPES.           83720000
         C     1,RHTYPE            IF NOT EQUAL, NO HITS.               84240000
         BNE   ALLZERO                                                  84760000
         L     5,CROUT             OTHERWISE, USE INTEGER COMPARE.      85280000
         B OUTER                                                        85800000
         SPACE                                                          86320000
ALLZERO  LTR   7,7                 SEE IF RESULT IS EMPTY.              86840000
         BZ FINI                                                        87360000
         LA    7,31(7)                                                  87880000
         SRL   7,5                 OTHERWISE, GET WORD COUNT.           88400000
         SR    1,1                                                      88920000
STZ      ST    1,M(8)              AND STORE ZEROS                      89440000
         LA    8,4(8)                                                   89960000
         BCT   7,STZ               A WORD AT A TIME.                    90480000
         B     FINI                                                     91000000
         EJECT                                                          91520000
*                                                                       92040000
*        CONSTANTS.                                                     92560000
*                                                                       93080000
MOVRANK  MVC   0(0,1),0(2)                                              93600000
         DC    0F'0'                                                    94120000
CROUT    DC    A(FCOMPARE)                                              94640000
         DC    A(DCOMPARE)                                              95160000
         DC    A(MIXED)                                                 95680000
EPS32    DC    F'32'                                                    96200000
EPS2     DC    F'2'                                                     96720000
         SPACE                                                          97240000
         EXTRN OPSPACE                                                  97760000
         EXTRN FETCH                                                    98280000
         LTORG                                                          98800000
         END                                                            99320000
./  ADD    NAME=APLSERAF
ERAF     TITLE 'ERROR RECOVERY AND FRIENDS                    05/11/70' 00210000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00420000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00630000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00840000
SEVERAL  CSECT                                                          01260000
         PRINT OFF       APLDEFN, ZSYMBOLS, PERTERM                     01470000
         PRINT NOGEN                                                    01680000
         COPY  APLDEFN                                                  01890000
         COPY  ZSYMBOLS                                                 02100000
         COPY  PERTERM                                                  02310000
         TITLE 'ERROR RECOVERY AND ERROR MESSAGE PRINTER      05/11/70' 02520000
         PRINT ON                                                       02730000
SEVERAL  CSECT                                                          02940000
         ENTRY ERROR                                                    03150000
         EXTRN DISPLAY                                                  03360000
         EXTRN GETSPACE                                                 03570000
         EXTRN MKGARB                                                   03780000
         EXTRN NONSTMTD                                                 03990000
         EXTRN SYNTXX                                                   04200000
         EXTRN TOBCD                                                    04410000
         EXTRN TYPEIN                                                   04620000
*              PRINTS ERROR MESSAGE FOLLOWED BY FAULTED STATEMENT,      04830000
*              THEN RESTORES INTERPRETER TO APPROPRIATE STATE           05040000
*              (USUALLY, IMMEDIATE-EXECUTION MODE).                     05250000
*        ON ENTRY, R1 CONTAINS ERROR CODE (A SMALL INTEGER).            05460000
         ENTRY DFLTRNG                                                  05670000
         ENTRY DZERR                                                    05880000
         ENTRY DFLTFP                                                   06090000
         ENTRY DFLTXDZ                                                  06300000
         ENTRY BGATTNX                                                  06510000
BGATTNX  BALR  LKR,0               TREAT DOUBLE ATTENTION OR CPU-TIME-  06720000
         USING *,LKR               LIMIT-EXCEEDED (EITHER OF WHICH      06930000
         ON    ATTN                                                     07140000
         LA    1,EINT              STOPS EXECUTION AT THE FIRST QUEND)  07350000
         B     ERROR               VERY MUCH LIKE AN EXECUTION ERROR.   07560000
         DROP  LKR                                                      07770000
DFLTRNG  EQU   *                                                        07980000
DZERR    EQU   *                                                        08190000
DFLTFP   EQU   *                                                        08400000
DFLTXDZ  EQU   *                                                        08610000
         LA    1,ERANGE                                                 08820000
ERROR    L     LR,QR13STK          THIS IS AN IMITATION PROLOG THAT     09030000
         BALR  PR,0                RESETS R13 TO THE BASE OF            09240000
         USING *,PR                                                     09450000
         AR    LR,MR               THE R13 STACK.  WE AVOID UNNECESSAR- 09660000
         LA    TLR,(LEND-LOCALS+23)/8*8(LR)  ILY LONG R13 STACK RE-     09870000
         USING LOCALS-16,LR        QUIREMENTS THIS WAY.                 10080000
*                                                                       10290000
         IC    1,ERTYPE(1)                                              10500000
         ST    1,ERNO                                                   10710000
*              MARK ALL STACKED DATA BETWEEN SVI AND PARREL AS GARBAGE. 10920000
*              THE ROUTINE THAT CALLED ERROR  M U S T  CLEAN ITS OWN    11130000
*              HOUSE BEFORE CALLING ERROR -- E.G. ALL TEMPS MUST HAVE   11340000
*              M-POINTERS ON THE STACK ABOVE SVI.                       11550000
         ICALL ERAST               CUT THE STACK BACK TO SVI=PARREL-4   11760000
         ICALL LOUTI               FORCE OUT POSSIBLE BUFFERRED TEXT    11970000
*                                                                       12180000
*        IN MOST OF THE FOLLOWING,                                      12390000
*              R2 = M-RELATIVE PARREL                                   12600000
*              R3 = CODESTRING SYLLABLE POINTER (FOR ERROR CARET)       12810000
*              R5 = DFN SYMBOL TABLE POINTER                            13020000
*              R6 = BYTE 0 OF DFN M-ENTRY, HOLDING LOCK BIT             13230000
*              R7 = CODESTRING POINTER                                  13440000
*                                                                       13650000
         SR    6,6                 WILL HOLD FUNCTION LOCK BIT          13860000
         L     2,PARREL            WE'LL NEED PARREL                    14070000
         IC    1,STFLAGS(2,MR)     MAKE STACK FLAGS ADDRESSABLE         14280000
         STC   1,ERFLAGS                                                14490000
         LH    3,STCPTR(2,MR)      R3 IS SYL INDEX WITHIN CODESTRING    14700000
         L     7,STCODE(2,MR)      PICK UP ADDRESS OF CODESTRING        14910000
         ST    6,STCODE(2,MR)      ERASE CODESTRING POINTER FROM STACK  15120000
         LTR   1,7                 BGATTN MAY GET US                    15330000
         BZ    ERR03C              HERE AFTER CODESTRING HAS ALREADY    15540000
*                                  BEEN RETURNED TO THE DIRECTORY.  IF  15750000
*                                  PTR IS 0, ASSUME THIS IS THE CASE.   15960000
         TM    ERFLAGS,STIMBIT     ARE WE IN AN IMMEDIATE-EXECUTION     16170000
         BO    ERR01               STATEMENT --                         16380000
*                                  NO.                                  16590000
*              RESTORE CODESTRING POINTER TO FUNCTION DIRECTORY,        16800000
*              AS IN END-OF-STATEMENT.                                  17010000
         L     5,STFNSPTR(2,MR)    FIRST FIND FUNCTION SPTR IN STACK    17220000
         L     8,M(5)              PICK UP FUNCTION MPTR FROM SYM TBL   17640000
         IC    6,MHEAD(8)          SAVE FUNCTION-PROTECT BIT IN R6      18060000
         LH    4,STLINE(2,MR)      GET LINE NUMBER                      18270000
         SLL   4,2                 TIMES FOUR GIVES WORD INDEX          18480000
         LA    4,MFCODE-M(4,8)     R4 IS RELATIVE LOCATION IN DIRECTORY 18690000
         ST    1,M(4)              PUT BASE ADDRESS OF CODESTRING BACK  19110000
         ST    4,MHEAD(1)          LINK CODESTRING BACK TO DIRECTORY.   19740000
         B     ERR03C                                                   19950000
*                                                                       20160000
*              ERROR IN IMMEDIATE-EXECUTION STATEMENT                   20370000
ERR01    ICALL MKGARB              MARK CODESTRING GARBAGE              20580000
         SR    2,2                 SET UP PLINE TO PRINT 6 BLANKS       20790000
*                                                                       21000000
*        PRINT '(TYPE) ERROR'      (IMM-EX, QUAD, UNLOCKED DFN,         21210000
*                                   TYPE NOT WS FULL OR INTERRUPT)      21420000
*        OR    '(TYPE)'            (WS FULL OR INTERRUPT ON IMM-EX,     21630000
*                                   QUAD, OR DFN NOT UNWINDING)         21840000
*        OR    '(DFN NAME) ERROR'  (LOCKED DFN, NOT UNWINDING MODE)     22050000
*                                                                       22260000
*        OR    NOTHING             (UNWINDING MODE)                     22470000
*                                                                       22680000
ERR03C   L     1,MPTBASE                                           2542 22890000
         MVC   ERNO(1),ACTIVE-PERTERM(1)  SAVE ATTENTION BIT       2542 23100000
         TM    RUNCTL,RCOLBIT      BYPASS ERROR-TYPE INDICATION    2542 23310000
         BO    ERR03E              IF IN UNWINDING MODE                 23520000
         L     1,ERNO              LOCATE TEXT OF ERROR TYPE            23730000
         LA    1,ERTEXT(1)                                              23940000
         CLI   ERNO+3,EINTT-ERTEXT TYPE ONLY, IF WS FULL OR INTERRUPT   24150000
         BNH   ERR03                                                    24360000
         EX    6,ERLKTM            IF ERROR IN LOCKED FN,               24570000
         BZ    ERR03A                                                   24780000
         LR    1,5                 ERROR TYPE IS FUNCTION NAME          24990000
         BAL   LKR,PNSUB                                                25200000
ERR03A   BAL   LKR,SQUIRT          PRINT TYPE (EXCEPT FOR WS FULL, INT) 25410000
         LA    1,ERTEXT            'ERROR'                              25620000
ERR03    BAL   LKR,SQUIRT                                               25830000
         ATT   OFF=ERR03B,RESET=YES  RESET ATTENTION IF ON         2542 26040000
ERR03B   BAL   LKR,LOUT            PRINT THE LINE                  2542 26250000
ERR03E   EQU   *                                                        26460000
         EX    6,ERLKTM            IF THIS IS A LOCKED FUNCTION,   2542 26670000
         BZ    ERR02               (IT'S NOT)                           26880000
         OI    RUNCTL,RCOLBIT+RCTRABIT ENTER/STAY IN UNWIND MODE   C003 27090000
         ICALL SYNTXX                                                   27300000
*                                                                       27510000
ERR02    MVI   RUNCTL,0            OUT OF UNWINDING MODE                27720000
         CLI   ERNO+3,ESYS-ERTEXT  ON SYSTEM ERROR,                     27930000
         BNZ   ERR025                                                   28140000
         TM    ERNO,ATTENM         CHECK SAVED ATTENTION BIT       2542 28350000
         BZ    ERR025              IF ATTENTION IS ON,             2542 28560000
         ATT   RESET=YES           FIRST RESET ATTENTION, THEN...  2542 28770000
         LEMP                    , LOAD A CLEAN WORKSPACE.              28980000
ERR025   LTR   7,7                 IF NO CODESTRING,                    29190000
         BZ    ERR07               INADVISABLE TO ATTEMPT DISPLAY.      29400000
         LR    1,2                 SET UP PARREL OR 0 FOR PLINE TO      29610000
         BAL   LKR,PLINE           PRINT F(N) OR SIX BLANKS             29820000
         CLI   ERNO+3,ESYN-ERTEXT  IF SYNTAX ERROR, ERROR SYL POINTER   30030000
         BE    ERR027              IS CORRECT.  OTHERWISE,              30240000
         CLI   NEXTOG,0            IF NEXTOG IS ON, ERROR SYL IS ONE    30450000
         BNE   ERR027                                                   30660000
         LA    3,1(3)              TO THE RIGHT.                        30870000
ERR027   LR    2,7                 STACKED CODESTRING POINTER           31080000
         ICALL DISPLAY             RECREATE THE FAULTED LINE.           31290000
ERR07    NI    MX+3,256-4          A NOT-QUITE-SUPERFLUOUS CHECK THAT   31500000
*                                  MX IS ON A WORD BOUNDARY             31710000
         ICALL TYPEIN              ALL DONE.  'CALL' TYPEIN AND LET     31920000
*                                  TYPEIN TAKE CARE OF DISCARDING THE   32130000
*                                  R13 STACK.                           32340000
ERLKTM   TM    *+4,0                                                    32550000
         DC    AL1(MFLKBIT)                                             32760000
ERTYPE   DC    AL1(ESYS-ERTEXT)    WHERE TO FIND TEXT OF ERROR TYPES    32970000
         DC    AL1(EMFU-ERTEXT)                                         33180000
         DC    AL1(ESYN-ERTEXT)                                         33390000
         DC    AL1(EIND-ERTEXT)                                         33600000
         DC    AL1(ERAN-ERTEXT)                                         33810000
         DC    AL1(ELEN-ERTEXT)                                         34020000
         DC    AL1(EVAL-ERTEXT)                                         34230000
         DC    AL1(0)                                                   34440000
         DC    AL1(0)                                                   34650000
         DC    AL1(0)                                                   34860000
         DC    AL1(0)                                                   35070000
         DC    AL1(ERNG-ERTEXT)                                         35280000
         DC    AL1(EDEP-ERTEXT)                                         35490000
         DC    AL1(EINTT-ERTEXT)                                        35700000
         DC    AL1(0)                                                   35910000
         DC    AL1(0)                                                   36120000
         DC    AL1(ENON-ERTEXT)                                         36330000
ERTEXT   DC    AL1(6,ZBLANK,ZE,ZR,ZR,ZO,ZR)                             36540000
EMFU     DC    AL1(7,ZW,ZS,ZBLANK,ZF,ZU,ZL,ZL)                          36750000
EINTT    DC    AL1(9,ZI,ZN,ZT,ZE,ZR,ZR,ZU,ZP,ZT)                        36960000
ESYS     DC    AL1(6,ZS,ZY,ZS,ZT,ZE,ZM)                                 37170000
ESYN     DC    AL1(6,ZS,ZY,ZN,ZT,ZA,ZX)                                 37380000
EIND     DC    AL1(5,ZI,ZN,ZD,ZE,ZX)                                    37590000
ERAN     DC    AL1(4,ZR,ZA,ZN,ZK)                                       37800000
ELEN     DC    AL1(6,ZL,ZE,ZN,ZG,ZT,ZH)                                 38010000
EVAL     DC    AL1(5,ZV,ZA,ZL,ZU,ZE)                                    38220000
ERNG     DC    AL1(6,ZD,ZO,ZM,ZA,ZI,ZN)                                 38430000
EDEP     DC    AL1(5,ZD,ZE,ZP,ZT,ZH)                                    38640000
ENON     DC    AL1(5,ZN,ZO,ZN,ZC,ZE)                                    38850000
LOCALS   DSECT                                                          39060000
ERNO     DS    F                                                        39270000
ERFLAGS  DS    FL1                                                      39480000
LEND     EQU   *                                                        39690000
         EJECT                                                          39900000
SEVERAL  CSECT                                                          40110000
         ENTRY ERAST                                                    40320000
ERAST    PROLOG                  , ERASE EXECUTION AND DIAGRAM STACKS   40530000
*                                  DOWN TO PARREL AND 'STMT' DIAGRAM.   40740000
         LM    2,3,SVI ,PARREL     FIND TOP OF STACK                    40950000
*                                  START OUT BY GARBAGING 'PARAMETER 0' 41160000
         LA    LKR,STPARAM(3)      WHICH MAY BE AN OP SUBSCRIPT    3590 41370000
         C     LKR,QSYMBOT         CASE OF VERY OLD                3590 41580000
         BNL   ERA3                WS WITH STACK 4 BYTES TOO SHORT      41790000
         L     1,M(LKR)                                            3590 42000000
         SR    0,0                                                      42210000
         ST    0,M(LKR)            SYNT ERR HAS OP SUBSCRIPT       3590 42420000
         B     ERA8                STASHED HERE WHILE THE EXPRESSION TO 42630000
*                                  ITS RIGHT WAS EVALUATED.             42840000
*                                                                       43050000
ERA3     LA    2,4(2)              NEXT STACK ENTRY IS 4 ABOVE SVI.     43260000
         ST    2,SVI               IRRELEVANT EXCEPT FOR ERROR-RECOVERY 43470000
*                                  (IT KEEPS US FROM GETTING REPEATED   43680000
*                                  PROGRAM CHECKS ON THE SAME BAD STACK 43890000
*                                  ENTRY)                               44100000
         CR    2,3                 HAVE WE REACHED PARREL --            44310000
         BNL   ERA4                YES.  STACK COLLAPSING IS DONE.      44520000
         L     1,M(2)              NO.  KILL THE NEXT STACK ENTRY.      44730000
ERA8     C     1,QF24BITS          THE ONLY STACK ENTRIES WE WANT TO    44940000
*                                  MARK ARE POSITIVE AND GREATER THAN   45150000
*                                  (2*24)-1.  OTHERS ARE SIMPLY INDI-   45360000
*                                  RECT BST ENTRIES, OPERATORS, END-OF- 45570000
*                                  LIST FLAGS, OR SOME SUCH.  WE WANT   45780000
*                                  TO CATCH ONLY EST ENTRIES.           45990000
         BNH   ERA3                NOT AN EST ENTRY.                    46200000
         ICALL MKGARB              GARBAGE IT.                          46410000
         B     ERA3                BACK FOR NEXT.                       46620000
ERA4     S     3,QF4               GIVE SVI VALUE OF 4 LESS THAN PARREL 46830000
         ST    3,SVI                                                    47040000
         L     1,DIASTPTR          STARTING AT PRESENT TOP OF STACK,    47250000
         L     2,=A(NONSTMTD)      RUN DIAGRAM STACK BACK TO            47460000
         XR    0,0                 'STMT' DIAGRAM. LOOK FOR FIRST  3562 47670000
ERA6     IC    0,DIAST(1)          REFERENCE TO 'STMT' IN PRESENT  3562 47880000
         C     0,0(2)              DIAGRAM                         3562 48090000
         ST    1,DIASTPTR                                          3562 48300000
         BCTR  1,0                                                 3562 48510000
         BNL   ERA6                                                     48720000
         IRETURN                                                        48930000
         TITLE 'PRINT WORKSPACE OR FUNCTION NAME              05/11/70' 49140000
SEVERAL  CSECT                                                          49350000
         ENTRY PRWSNAME                                                 49560000
PRWSNAME PROLOG PRWL,PRWLEND                                            49770000
         MVC   PWN(LWFLAB),0(1)    PUT FILE LABEL IN A KNOWN PLACE      49980000
         LA    1,PWS4                                                   50190000
         CLI   PWN+WFLNAME-WFLLIB,11                                    50400000
         BH    PWS1                CHAR COUNT GTR 11 MEANS CLEAR WS     50610000
         L     0,PWN+WFLLIB-WFLLIB                                      50820000
         L     3,MPTBASE                                                51030000
         C     0,PTMAN-PERTERM(3)                                       51240000
         BE    PWS2                DON'T PRINT LIB NO. IF IT MATCHES    51450000
         ICALL PRNUM,*             SIGNON NUMBER                        51660000
         LA    1,ZBLANK                                                 51870000
         ICALL TOPRINT,*           A BLANK TO SEPARATE NO. AND NAME     52080000
PWS2     LA    1,PWN+WFLNAME-WFLLIB    PRINT NAME                       52290000
PWS1     ICALL SQUIRT,*                                                 52500000
         ICALL LOUT,*                                                   52710000
         IRETURN                                                        52920000
         SPACE 2                                                        53130000
         ENTRY PLINF                                                    53340000
         ENTRY PLINE                                                    53550000
*        PRINT CURRENT FUNCTION NAME AND BRACKETED LINE NUMBER          53760000
PLINF    L     1,PARREL            SET UP CURRENT FUNCTION AS ARGUMENT  53970000
*                                  FOR PLINE.                           54180000
*        PRINT FUNCTION NAME AND BRACKETED LINE NUMBER, OR 6 BLANKS.    54390000
*        ON ENTRY, R1 = RELATIVE SETTING FOR STACKED FUNCTION INFO      54600000
*                       OR 0                                            54810000
PLINE    PROLOG PLOC,PLEND                                              55020000
         STM   0,2,PLOC            SAVE REGISTERS                       55230000
         LTR   2,1                 IF R1 IS ZERO                        55440000
PLIN0    LA    1,PLINDENT                                               55650000
         BZ    PLIN6               PRINT 6 BLANKS.                      55860000
         L     1,STFNSPTR(2,MR)    LOCATE FUNCTION PRINTNAME            56070000
         N     1,QF24BITS                                               56280000
         BZ    PLIN0               6 BLANKS ALSO IF FN SPTR IS ZERO     56490000
         BAL   LKR,PNSUB           GET ABS ADDR OF PRINTNAME            56700000
PLIN2    MVC   PLOC+12(1),0(1)     SAVE LENGTH FOR RIGHT BRACKET PRINT  56910000
         ICALL SQUIRT,*            SQUIRT THE PRINTNAME                 57120000
         LA    1,ZLBR              FUNCTION NAME PRINTED.  NOW FOR      57330000
         ICALL TOPRINT,*           THE BRACKETS                         57540000
         LH    0,STLINE(2,MR)      AND THE LINE NUMBER                  57750000
         ICALL PRNUM,*                                                  57960000
         LA    1,PLRBR             NOW THE RIGHT BRACKET AND ONE BLANK  58170000
         CLI   PLOC+12,1                                                58380000
         BH    PLIN6               OR TWO IF 1-CHAR FN NAME, TO GET     58590000
         LA    1,PLRBR2            TO COLUMN 7                          58800000
PLIN6    ICALL SQUIRT,*                                                 59010000
         LM    0,2,PLOC                                                 59220000
         IRETURN                   AND THAT'S ALL.                      59430000
         DROP  PR                                                       59640000
*                                                                       59850000
*                                                                       60060000
*        GET ABS ADDR OF PRINTNAME.                                     60270000
*        ON ENTRY, R1 = M-RELATIVE SYMBOL TABLE POINTER                 60480000
PNSUB    ST    LKR,0(TLR)          WE NEED LINK REGISTER                60690000
         BALR  LKR,0               FOR ADDRESSABILITY                   60900000
         USING *,LKR                                                    61110000
         N     1,QF24BITS                                               61320000
         C     1,QSYMBOT           IF FUNCTION NAME HAS BEEN SHADOWED,  61530000
         BNL   PNS1                                                     61740000
         S     1,QF4               IT POINTS TO STACK WHICH POINTS      61950000
         L     1,M(1)              TO SYMBOL TABLE ENTRY (AND PNAME)    62160000
PNS1     L     LKR,0(TLR)                                               62580000
         DROP  LKR                                                      62790000
         LA    1,M+4(1)            ABS ADDR OF SECOND WORD IN SYM TBL   63000000
         CLI   0(1),3              IS RESULT IF CHAR COUNT LEQ 3        63210000
         BCR   13,LKR BNH                                               63420000
         L     1,0(1)              ELSE RESULT IS POINTED TO BY R1      63630000
         LA    1,MPNAME(1)                                              64050000
         BR    LKR                                                      64260000
*                                                                       64470000
PLINDENT DC    AL1(6)                                                   64680000
         DC    6AL1(ZBLANK)                                             64890000
PLRBR    DC    AL1(2,ZRBR,ZBLANK)                                       65100000
PLRBR2   DC    AL1(3,ZRBR,ZBLANK,ZBLANK)                                65310000
PWS4     DC    AL1(8,ZC,ZL,ZE,ZA,ZR,ZBLANK,ZW,ZS)                       65520000
PRWL     DSECT                                                          65730000
PWN      DS    XL(LWFLAB)                                               65940000
PRWLEND  EQU   *                                                        66150000
PLOC     DSECT                                                          66360000
         DS    4F                                                       66570000
PLEND    EQU   *                                                        66780000
         TITLE 'PRINT ONE CHARACTER OR TEXT STRING            05/11/70' 66990000
SEVERAL  CSECT                                                          67200000
         ENTRY TOPRINT                                                  67410000
*              ON ENTRY,                                                67620000
*                  R1 = CHARACTER TO BE PRINTED.                        67830000
*              DESTROYS ONLY R0, R1                                     68040000
TOPRINT  LR    0,1                                                      68250000
         LH    1,OBUFPTR           PUT ONE CHARACTER INTO THE           68460000
         STC   0,OBUF(1)           OUTPUT BUFFER.                       68670000
         LA    0,1(1)              BUMP BUFFER POINTER                  68880000
         STH   0,OBUFPTR                                                69090000
         CH    0,OBUFLIM           IF WE'VE REACHED THE END OF THE      69300000
         BALR  1,0                                                      69510000
         USING *,1                                                      69720000
         BH    LOUT                BUFFER, FORCE IT OUT.                69930000
         DROP  1                                                        70140000
         BR    LKR                                                      70350000
*                                                                       70560000
*        SQUIRT -- MOVE N CHARACTERS TO OUTPUT BUFFER                   70770000
*                                                                       70980000
*        ON ENTRY, R1 = ADDRESS OF CHARACTERS TO BE MOVED.              71190000
*              IF ENTERED AT SQUIRT, ADDRESS IS ABSOLUTE.               71400000
*              IF ENTERED AT SQUIRTM, ADDRESS IS M-RELATIVE.            71610000
*                  FIRST CHARACTER IS COUNT OF FOLLOWING CHARACTERS,    71820000
*                  AND IS NOT MOVED.                                    72030000
*                  IF THE NUMBER OF CHARACTERS EXCEEDS THE SPACE        72240000
*                  REMAINING IN THE OUTPUT BUFFER, THE BUFFER IS FORCED 72450000
*                  OUT AND THE CHARACTERS ARE INSERTED FOLLOWING SIX    72660000
*                  BLANKS IN THE LEFT END.                              72870000
*              DESTROYS REGISTER 0 .                                    73080000
         ENTRY SQUIRT                                                   73290000
         ENTRY SQUIRTM                                                  73500000
SQUIRTM  AR    1,MR                ABSOLUTIZE POINTER                   73710000
SQUIRT   PROLOG SQL,SQLEND                                              73920000
         STM   1,5,SQRS            SAVE REGS OVER SQUIRT                74130000
         SR    2,2                                                      74340000
         LA    3,0(1)              LOSE BYTE 0 FOR COMPARISONS AT SQ04  74760000
         IC    2,0(3)              PUT CHARACTER COUNT IN R2            74970000
         LH    5,OBUFPTR                                                75180000
SQ03     LH    4,OBUFLIM                                                75390000
         SR    4,5                 R4 = REMAINING LENGTH IN LINE        75600000
         CR    4,2                 PREPARE TO MOVE                      75810000
         BL    SQ06                MIN OF STRING AND BUFFER LENGTHS     76020000
         LR    4,2                                                      76230000
SQ01     LA    0,0(4,5)            UPDATE POINTER                       76440000
         STH   0,OBUFPTR                                                76650000
         AR    5,MR                GET ABSOLUTE BUFFER POINTER          76860000
         EX    4,SQM               MOVE CHARACTER STRING TO BUFFER      77070000
*                                  (1 CHAR TOO MANY FROM LAZINESS)      77280000
         SR    2,4                                                      77490000
         BP    SQ04                IS MOVE COMPLETED --                 77700000
SQ05     LM    1,5,SQRS            YES.                                 77910000
         IRETURN                                                        78120000
SQ06     LTR   5,5                 IF NOT AT LEFT END OF LINE (TRUE     78330000
         BZ    SQ01                ONLY THE 1ST TIME THROUGH HERE),     78540000
         SR    4,4                 FORCE OUT CURRENT LINE.              78750000
SQ04     AR    3,4                 ADD MOVE LENGTH TO STRING ADDRESS    78960000
         SR    5,5                 R5 HOLDS NEW OBUFPTR                 79170000
         CR    3,MR                                                     79380000
         BL    SQ08                WE MUST RELATIVIZE ANY ADDRESS       79590000
         CR    3,LR                BETWEEN MR AND LR (OUR LOCALS, AND   79800000
         BH    SQ08                LAST INFORMATION IN WS) --           80010000
         SR    3,MR                IT'S M-RELATIVE.                     80220000
         ICALL LOUT,*              LOUT MIGHT SUSPEND US                80430000
         AR    3,MR                AND MR MIGHT BE DIFFERENT HERE.      80640000
         B     SQ03                                                     80850000
SQ08     ICALL LOUT,*              FOR ABSOLUTE (INTERP-RELATIVE) ADDRS 81060000
         B     SQ03                                                     81270000
SQM      MVC   OBUF-M(0,5),1(3)    SOURCE STRING IS OFFSET BY 1         81480000
*                                  BECAUSE OF COUNT BYTE.               81690000
SQ6BL    DC    6AL1(ZBLANK)                                             81900000
SQL      DSECT                                                          82110000
*                                                                       82320000
SQRS     DS    5F                                                       82530000
SQLEND   EQU   *                                                        82740000
         TITLE 'X R H O  --  P R O D U C T   O V E R   R H O   V A R B' 82950000
SEVERAL  CSECT                                                          83160000
         ENTRY XRHO                                                     83370000
XRHO     STM   2,4,0(TLR)          COMPUTE PRODUCT OVER RANK VECTOR     83580000
         BALR  4,0                 OF ENTRY ADDRESSED BY R1             83790000
*                                  RETURNS RESULT IN R0, R1             84000000
         USING *,4                                                      84210000
         LR    2,1                 MOVE MPTR TO R2                      84420000
         LH    3,MRANK(2)          LOOK AT RANK                         84630000
         SR    0,0                                                      84840000
         LA    1,1                                                      85050000
         S     3,QF4               IS IT SCALAR --                      85260000
         BM    XRHO2               YES.  RESULT IS 1.                   85470000
         L     1,MRHO(2)           IS IT VECTOR --                      85680000
         BZ    XRHO2               YES.  RESULT IS LENGTH.              85890000
         SRL   3,2                 HIGHER-DIMENSIONAL ARRAY.  SET UP    86100000
XRHO3    M     0,MRHO+4(2)         MULTIPLY BY NEXT COMPONENT OF RHO    86310000
         LA    2,4(2)              BUMP MPTR                            86520000
         BCT   3,XRHO3             AND GO BACK FOR NEXT.                86730000
XRHO2    LM    2,4,0(TLR)          FINISHED.  RELOAD SAVED REGISTERS    86940000
         BR    LKR                 AND EXIT.                            87150000
         DROP  4                                                        87360000
         TITLE '      PRINT-LINE OUTPUT ROUTINE  --  USES TYO 05/11/70' 87570000
         ENTRY LOUT                                                     87780000
         ENTRY LOUTI                                                    87990000
         ENTRY LOUTN                                                    88200000
LOUTI    CLI   OBUFPTR+1,0         SAME AS LOUT BUT IGNORE EMPTY LINE   88410000
         BCR   8,LKR                                                    88620000
LOUT     ST    2,0(TLR)            SAVE R2 WHILE WE FOOL AROUND         88830000
         BALR  2,0                 DELETING TRAILING BLANKS.            89040000
         USING *,2                                                      89250000
         LH    1,OBUFPTR                                                89460000
         LA    0,1(1)                                                   89670000
         AR    1,MR                                                     89880000
LOUT1    BCTR  1,0                 SCAN FROM RIGHT END OF BUFFER FOR    90090000
         CLI   OBUF-M(1),ZBLANK    NONBLANKS.                           90300000
         BNE   LOUT2               FOUND ONE                            90510000
         BCT   0,LOUT1             NOTE THAT THIS JUST WORKS IF PTR=0   90720000
         A     0,QF1                                                    90930000
LOUT2    MVI   OBUF-M+1(1),ZCR     DROP IN CR FOLLOWING LAST NONBLANK   91140000
         STH   0,OBUFPTR           SS COUNT                             91350000
         L     2,0(TLR)            RELOAD SAVED R2                      91560000
         DROP  2                                                        91770000
*                                                                       91980000
LOUTN    LH    1,OBUFPTR           OUTPUT LINE, NO CARRIAGE RETURN      92190000
         STH   1,LLLO              SAVE LINE LENGTH FOR CHAR EDITING    92400000
         LA    0,ZEOB                                                   92610000
         STC   0,OBUF(1)           ALWAYS APPEND AN EOB                 92820000
         TYO   OBUFPTR             SEND LINE TO APLSUP                  93030000
         SR    0,0                 AND SET THE COUNT TO ZERO.           93240000
         STH   0,OBUFPTR                                                93450000
         STH   0,LGCPTR            QUAD' OUTPUT -- NO PREVIOUS OUTPUT   93660000
*                                  ON THIS LINE, EITHER.                93870000
         QUEND                                                          94080000
         BR    LKR                                                      94290000
         TITLE 'PRNUM -- PRINT INTEGER NUMBER                 05/11/70' 94500000
SEVERAL  CSECT                                                          94710000
*                                                                       94920000
*              CALL TOBCD TO PRINT INTEGER IN R0                        95130000
*                                                                       95340000
         ENTRY PRNUM                                                    95550000
PRNUM    PROLOG PRNL,PRNLEND                                            95760000
         STM   0,3,PRNREG                                               95970000
         LA    2,2                 INTEGER TYPE                         96180000
         SR    3,3                                                      96390000
         ICALL TOBCD                                                    96600000
         LM    0,3,PRNREG                                               96810000
         IRETURN                                                        97020000
         SPACE                                                          97230000
PRNL     DSECT                                                          97440000
PRNREG   DS    4F                                                       97650000
PRNLEND  EQU   *                                                        97860000
         SPACE 2                                                        98070000
SEVERAL  CSECT                                                          98280000
QF1      DC    F'1'                                                     98490000
QF4      DC    F'4'                                                     98700000
QF12     DC    F'12'                                                    98910000
QF16     DC    F'16'                                                    99120000
QF24BITS DC    A(X'FFFFFF')                                             99330000
         LTORG                                                          99540000
         END                                                            99750000
./  ADD    NAME=APLSFFSS
FFSS     TITLE 'F E T C H   A N D   S T O R E                 05/11/70' 00350000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00700000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01050000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01400000
         PRINT OFF       APLDEFN                                        02100000
FFSS     CSECT                                                          02450000
         COPY  APLDEFN                                                  02800000
         TITLE 'F E T C H   A N D   S T O R E                 05/11/70' 03150000
         PRINT ON,NOGEN                                                 03500000
FFSS     CSECT                                                          03850000
         ENTRY FETCH                                                    04200000
         ENTRY FETCHINT                                                 04550000
         EXTRN ERROR                                                    04900000
*                                                                       05250000
*        FETCH (IDX,TYPE,BASE)                                          05600000
*                                                                       05950000
*              PUTS INTO REGISTERS 0 AND 1 THE VALUE AT BASE(IDX),      06300000
*              TYPE-CONVERTED ACCORDING TO TYPE.                        06650000
*        ON ENTRY,                                                      07000000
*              R2 = INDEX IN ELEMENTS (I.E. NOT BYTES)                  07350000
*              R4 = BASE ADDRESS OF DATA IN M-ENTRY (M-RELATIVE)        07700000
*              R3 = TYPE-CONVERSION CODE, AS FOLLOWS --                 08050000
*                                    -- TO --                           08400000
*                                  B    I    F    C                     08750000
*                                                                       09100000
*                      BOOLEAN     1    5    6    *                     09450000
*        -- FROM --    INTEGER     7    2    8    *                     09800000
*                      FLOATING    9   10    3    *                     10150000
*                      CHARACTER   *    *    *    4                     10500000
*                                                                       10850000
*                     11,12 FOR UNFUZZED FLOATING TO BOOLEAN AND        11200000
*                     INTEGER RESPECTIVELY                              11550000
*                                                                       11900000
*        ON EXIT,                                                       12250000
*                  R0,1 = RESULT, ALL TYPES                             12600000
*              F0 = RESULT, IF FLOATING                                 12950000
*              F2 IS NOT SAVED IF THE FETCH CODE IS 9,10,11,12          13300000
*              ALL OTHER REGISTERS PRESERVED                            13650000
*                                                                       14000000
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 14350000
*        FETCH AND STORE BYPASS THE LINKAGE MACROS                      14700000
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 15050000
*                                                                       15400000
         USING FEL,TLR                                                  15750000
FETCHINT BALR  1,0                                                      16100000
         USING *,1                                                      16450000
         IC    3,TOINT-1(3)        GET INT CONVERSION TYPE FROM ARG TYP 16800000
FETCH    BALR  1,0                 R1 HAS PRECARIOUS EXISTENCE AS BASE  17150000
         USING *,1                                                      17500000
         STM   2,3,FRSV            SAVE R2, R3 OVER FETCH               17850000
         CL    3,QF13              FOR DEBUGGING CHECK THAT TYPE IS     18200000
         SLL   3,2                 IN RANGE.  THEN MAKE IT A WORD INDEX 18550000
         BNH   *+4(3)              AND BRANCH TO APPROPRIATE CONVERSION 18900000
         B     SYSR                SYSTEM ERROR -- OUT-OF-RANGE TYPE.   19250000
         B     BTOB                                                     19600000
         B     ITOI                                                     19950000
         B     FTOF                                                     20300000
         B     CTOC                                                     20650000
         B     BTOI                                                     21000000
         B     BTOF                                                     21350000
         B     ITOB                                                     21700000
         B     ITOF                                                     22050000
         B     FTOB                                                     22400000
         B     FTOI                                                     22750000
         B     FTOBNF                                                   23100000
         B     FTOINF                                                   23450000
         B     RNGERR              CHARACTER-NUMERIC CONVERSION         23800000
BTOI     EQU   *                   BOOLEAN-TO-INTEGER CONVERSION        24150000
         LA    0,1                 PRELOAD INTEGER 1 RESULT             24500000
         LTR   2,2                                                      24850000
         BNZ   NOTFIRST                                                 25200000
         IC    0,M(4)              IF FIRST ELEMENT THEN THIS IS FAST   25550000
         SRL   0,7                                                      25900000
         L     3,FRSV+4                                                 26250000
         BR    LKR                                                      26600000
NOTFIRST SRDL  2,3                 GET BYTE INDEX                       26950000
         AR    2,4                 BASE-RELATIVE                        27300000
         IC    2,M(2)              BIT IS IN THIS BYTE                  27650000
         SRL   3,27                MAKE RESIDUE A WORD INDEX            28000000
         N     2,QBITS(3)          MASK OUT OTHER GARBAGE               28350000
         BNZ   FRETS               IF NOT ZERO, QUIT WITH CONSTANT 1.   28700000
         LR    0,2                 IT'S ZERO.                           29050000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  29400000
         BR    LKR                                                      29750000
BTOF     EQU   *                   BOOLEAN-TO-FLOATING CONVERSION       30100000
         LD    0,DONE              PRELOAD FLOATING 1 RESULT            30450000
         SRDL  2,3                 GET BYTE INDEX                       30800000
         AR    2,4                 BASE-RELATIVE                        31150000
         IC    2,M(2)              BIT IS IN THIS BYTE                  31500000
         SRL   3,27                MAKE RESIDUE A WORD INDEX            31850000
         N     2,QBITS(3)          MASK OUT OTHER GARBAGE               32200000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  32550000
         BNZ   BTOF1               IF NOT ZERO, RETURN 1.0              32900000
         LE    0,DZER              OTHERWISE WITH 0.0                   33250000
         SR    0,0                                                      33600000
         SR    1,1                 LOSE BASE REGISTER                   33950000
         BR    LKR                                                      34300000
BTOF1    L     0,DONE              LOAD FLOATING 1.0                    34650000
         SR    1,1                                                      35000000
         BR    LKR                                                      35350000
BTOB     EQU   *                   BOOLEAN-TO-BOOLEAN CONVERSION.       35700000
         SRDL  2,3                                                      36050000
         AR    2,4                                                      36400000
         IC    0,M(2)              GET BYTE OF INTEREST                 36750000
         SRL   3,29                AND SHIFT COUNT                      37100000
         SLL   0,24(3)             PUT BIT IN BIT 0 OF R0               37450000
         N     0,QFBIT0            AND MASK OUT GARBAGE.                37800000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  38150000
         BR    LKR                                                      38500000
FTOF     SLL   2,3                 FLOATING-TO-FLOATING CONVERSION.     38850000
         AR    2,4                 GET DOUBLEWORD INDEX                 39200000
         AR    2,MR                ABSOLUTE.                            39550000
         LM    0,1,0(2)            NOTE THAT FETCHED VALUE MAY NOT BE   39900000
         STM   0,1,DTEMP           ON A DOUBLEWORD BOUNDARY.            40250000
         LD    0,DTEMP                                                  40600000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  40950000
         BR    LKR                                                      41300000
CTOC     AR    2,4                 CHARACTER-TO-CHARACTER CONVERSION.   41650000
         IC    0,M(2)              PICK UP CHARACTER                    42000000
         SLL   0,24                AND LEFT-JUSTIFY IT.                 42350000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  42700000
         BR    LKR                                                      43050000
ITOI     SLL   2,2                 INTEGER-TO-INTEGER CONVERSION.       43400000
         AR    2,4                 LOCATE WORD                          43750000
         L     0,M(2)              PICK IT UP                           44100000
         LM    2,3,FRSV            RESTORE SAVED R2, R3                 44450000
         BR    LKR                                                      44800000
ITOB     SLL   2,2                 INTEGER-TO-BOOLEAN CONVERSION.       45150000
         AR    2,4                 AS USUAL, GET M-RELATIVE ADDRESS     45500000
         L     0,M(2)                                                   45850000
ITOB2    CL    0,QF1               CHECK FOR VALUE OF 1 OR 0            46200000
         SLL   0,31                PUT UNITS BIT IN SIGN                46550000
         BH    RNGERR              VALUE NOT 1 OR 0                     46900000
         LM    2,3,FRSV            RESTORE SAVED R2, R3                 47250000
         BR    LKR                                                      47600000
ITOF     SLL   2,2                 INTEGER-TO-FLOATING CONVERSION.      47950000
         AR    2,4                                                      48300000
         L     0,M(2)              LOAD INTEGER                         48650000
         AL    0,DUN231+4          MAKE EXCESS-2*31                     49000000
         ST    0,DTEMP+4           LOAD AN UNNORMALIZED ZERO AROUND IT, 49350000
         LD    0,DTEMP                                                  49700000
         LE    0,DUN231            WITH UNNORMALIZED ZERO PREFIX     PA 50050000
         SD    0,DUN231            REMOVE EXCESS AND NORMALIZE          50400000
         STD   0,DTEMP                                                  50750000
         LM    0,3,DTEMP                                                51100000
         BR    LKR                                                      51450000
FTOBNF   EQU   *                   UNFUZZED FLOATING-TO-BOOLEAN CONV.   51800000
FTOINF   EQU   *                   UNFUZZED FLOATING-TO-INTEGER CONV.   52150000
         MVI   FFLAG,0             FLAG FOR NO FUZZ IN CONVERSION       52500000
         B     *+8                                                      52850000
FTOB     EQU   *                   FLOATING-TO-BOOLEAN CONVERSION       53200000
FTOI     EQU   *                   FLOATING-TO-INTEGER CONVERSION       53550000
         MVI   FFLAG,1             FLAG FOR FUZZED CONVERSION           53900000
         SLL   2,3                 GET DOUBLEWORD INDEX                 54250000
         AR    2,4                 M-RELATIVE                           54600000
         AR    2,MR                ABSOLUTE                             54950000
         LM    2,3,0(2)                                                 55300000
         STM   2,3,DTEMP                                                55650000
         LD    0,DTEMP             LOAD TENTATIVE INTEGER               56000000
         LPDR  2,0                 MAKE POSITIVE COPY                   56350000
         CE    2,TWO31             IN RANGE ?                           56700000
         BNL   RNGERR                                                   57050000
         STE   2,DTEMP1                                                 57400000
         MVC   DTEMP1+1(7),CNVTFUZZ+1 MOVE IN FUZZ BITS                 57750000
         AD    2,DTEMP1            ADD IN RELATIVE FUZZ                 58100000
         AW    2,RDUNZ                                                  58450000
         STD   2,DTEMP2                                                 58800000
         L     0,DTEMP2+4          PICK UP AN INTEGER                   59150000
         LTER  0,0                                                      59500000
         BNL   *+8                                                      59850000
         LCR   0,0                 MAKE 2'S COMPLEMENT IF NEGATIVE      60200000
         LPER  0,0                                                      60550000
         AD    2,DZER              RENORMALIZE INTEGER                  60900000
         SDR   0,2                 GET REMAINDER                        61250000
         BZ    TESTBOOL            IF ZERO THEN EXACT INTEGER EXIT      61600000
         CLI   FFLAG,0             IF NO FUZZING THEN RANGE ERROR       61950000
         BE    RNGERR                                                   62300000
         LPER  0,0                                                      62650000
         LD    2,DTEMP1            LOAD RELATIVE FUZZ                   63000000
         AD    2,DZER              NORMALIZE REL FUZZ                   63350000
         CDR   0,2                 IF REMAINDER LT REL FUZZ THEN OK     63700000
         BNH   TESTBOOL                                                 64050000
         LD    0,DTEMP                                                  64400000
         LPER  0,0                                                      64750000
         CD    0,CNVTFUZZ          IF INPUT IS GT ABS FUZZ RNG ERROR    65100000
         BH    RNGERR                                                   65450000
         SR    0,0                 OTHERWISE SET TO ZERO                65800000
TESTBOOL TM    FRSV+7,1            IF FLOATING TO BOOLEAN THEN          66150000
         BO    ITOB2               CONVERT INTEGER TO BOOLEAN           66500000
FRETS    LM    2,3,FRSV            RESTORE SAVED REGISTERS              66850000
         BR    LKR                                                      67200000
SYSR     L     LKR,=A(ERROR)                                            67550000
         LA    1,ESYSTEM                                                67900000
         BALR  LKR,LKR             REALLY AN  ICALL ERROR               68250000
         PRINT GEN                                                      68600000
RNGERR   LM    2,3,FRSV                                                 68950000
         SIGNAL RNG                                                     69300000
         EJECT                                                          69650000
*        STORE (VALUE,IDX,TYPE,BASE)                                    70000000
*              PUTS INTO BASE(IDX) THE VALUE IN REGISTER R0 OR F0.      70350000
*              THE VALUE IS ASSUMED TO BE IN THE CORRECT TYPE.          70700000
*              A BIT OR CHARACTER IS LEFT-JUSTIFIED IN R0.              71050000
*                                                                       71400000
*              ON ENTRY,                                                71750000
*              R0 = VALUE, IF NOT FLOATING                              72100000
*              F0 = VALUE, IF FLOATING                                  72450000
*              R2 = 0-ORIGIN INDEX IN ELEMENTS (I.E, NOT IN BYTES)      72800000
*              R3 = TYPE (1, 2, 3, OR 4)                                73150000
*              R4 = BASE ADDRESS OF DATA (M-RELATIVE)                   73500000
*                                                                       73850000
*              ON EXIT,                                                 74200000
*              R0,1 GARBAGE                                             74550000
*              ALL OTHERS SAVED                                         74900000
*              STORE MUST NOT TURN ON FIXED OVERFLOW                    75250000
         ENTRY STORE                                                    75600000
STORE    BALR  1,0                 ESTABLISH PRECARIOUS ADDRESSING      75950000
         USING *,1                                                      76300000
         STM   2,3,FRSV            SAVE R2, R3 OVER STORE               76650000
         BCT   3,STINT             BRANCH ON TYPE TO APPROPRIATE STORE  77000000
         SRDL  2,3                 BOOLEAN STORE.  GET BYTE INDEX       77350000
         SRL   3,29                AND BIT INDEX                        77700000
         LTR   0,0                 SEGREGATE CASES.  EASIER THAN LOGIC. 78050000
         BNM   STB0                                                     78400000
         IC    3,BITS(3)           STORE 1.  PICK UP BIT IN BYTE        78750000
         AR    2,4                 GET DATA ADDRESS                     79100000
         AR    2,MR                ABSOLUTE                             79450000
         EX    3,OI                AND OR IN THE BIT.                   79800000
         LM    2,3,FRSV            RESTORE SAVED REGISTERS              80150000
         BR    LKR                                                      80500000
STB0     IC    3,UNBITS(3)         STORE 0.                             80850000
         AR    2,4                 GET DATA ADDRESS                     81200000
         AR    2,MR                ABSOLUTE                             81550000
         EX    3,NI                AND MASK OUT THE BIT.                81900000
         LM    2,3,FRSV            RESTORE SAVED R2, R3                 82250000
         BR    LKR                                                      82600000
STINT    BCT   3,STFLT             FALL THROUGH IF INTEGER              82950000
         SLL   2,2                 GET WORD INDEX                       83300000
         AR    2,4                 TO DATA, M-RELATIVE                  83650000
         ST    0,M(2)                                                   84000000
         LM    2,3,FRSV            RESTORE SAVED R2,R3                  84350000
         BR    LKR                                                      84700000
STFLT    BCT   3,STCH              FALL THROUGH ON FLOATING             85050000
         SLL   2,3                 GET DOUBLE-WORD INDEX                85400000
         AR    2,4                 TO DATA, M-RELATIVE                  85750000
         AR    2,MR                AND ABSOLUTE                         86100000
         STD   0,DTEMP             STORE F0 ON A DOUBLE-WORD            86450000
         LM    0,1,DTEMP           PICK IT UP AGAIN                     86800000
         STM   0,1,0(2)            AND STORE IT ON A WORD BOUNDARY      87150000
         LM    2,3,FRSV            RESTORE SAVED R2, R3                 87500000
         BR    LKR                                                      87850000
STCH     SRL   0,24                CHARACTER STORE                      88200000
         AR    2,4                 GET M-RELATIVE DATA ADDRESS          88550000
         STC   0,M(2)                                                   88900000
         LM    2,3,FRSV                                                 89250000
         BR    LKR                                                      89600000
BITS     DC    X'8040201008040201'                                      89950000
UNBITS   DC    X'7FBFDFEFF7FBFDFE'                                      90300000
OI       OI    0(2),0                                                   90650000
NI       NI    0(2),0                                                   91000000
TOINT    DC    FL1'5,2,10,11'                                           91350000
QBITS    DC    F'128,64,32,16,8,4,2,1'                                  91700000
QF1      EQU   QBITS+28                                                 92050000
QF13     DC    F'13'                                                    92400000
TWO31    DC    X'48800000'                                              92750000
         DS    0D                                                       93100000
DUN231   DC    X'4E00000080000000'                                      93450000
QFBIT0   EQU   *-4                                                      93800000
DZER     DC    D'0'                                                     94150000
DONE     DC    D'1'                                                     94500000
DCOMP    DC    X'4E00000100000000'                                      94850000
RDUNZ    DC    X'4E00000000000000' REALLY TRULY UNNORMALIZED ZERO       95200000
CNVTFUZZ DC    X'40000000000003FF'                                      95550000
         LTORG                                                          95900000
FEL      DSECT                                                          96250000
DTEMP    DS    2D                                                       96600000
FRSV     EQU   DTEMP+8                                                  96950000
DTEMP1   DS    D                                                        97300000
DTEMP2   DS    D                                                        97650000
FFLAG    DS    XL1                                                      98000000
FEND     EQU   *                                                        98350000
         END                                                            98700000
./  ADD    NAME=APLSGOUT
GOUT     TITLE 'G E N E R A L   O U T P U T   R O U T I N E   05/11/70' 00370000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00740000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01110000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01480000
         PRINT OFF       APLDEFN, PERTERM, ZSYMBOLS                     02220000
GOUT     CSECT                                                          02590000
         COPY  APLDEFN                                                  02960000
         COPY  PERTERM                                                  03330000
         COPY  ZSYMBOLS                                                 03700000
         TITLE 'G E N E R A L   O U T P U T   R O U T I N E   05/11/70' 04070000
         PRINT NOGEN                                                    04440000
         PRINT ON                                                       04810000
GOUT     CSECT                                                          05180000
*                                                                       05550000
*        PRINT VALUE OF QUANTITY POINTED TO BY R1.                      05920000
         EXTRN ERROR                                                    06290000
         EXTRN FETCH                                                    06660000
         EXTRN LOUT                                                     07030000
         EXTRN LOUTI                                                    07400000
         EXTRN SQUIRT                                                   07770000
         EXTRN TOBCD                                                    08140000
         EXTRN TOPRINT                                                  08510000
         EXTRN XRHO                                                     08880000
         PROLOG GOUL,GOULND                                             09250000
*  QUADP OUTPUT IS NOT TO BE GIVEN SPECIAL TREATMENT AS IN THE PAST A05 09620000
DSECT1   DSECT                                                      A05 09990000
         CLI   SYL+1,1+2*ZQUADP    IF THIS IS QUAD-PRIME OUTPUT,        10360000
         BNE   GO10                                                     10730000
         MVC   LGCPTR,OBUFPTR      RECORD CARRIER POSITION AT END OF    11100000
*                                  PREVIOUS OUTPUT.                     11470000
GOUT     CSECT                                                      A05 11840000
GO10     LTR   1,1                                                      12210000
         BP    GO1                                                      12580000
         BZ    GO9                 IGNORE 0 ARG EXCEPT TO FORCE CR      12950000
         L     1,M(1)                                                   13690000
GO1      DS    0H                                                       14060000
         LA    2,MLIST(1)                                               14430000
         TM    0(2),MLSTBIT        IF THIS IS A LIST,                   14800000
         LA    2,1                                                      15170000
         BZ    GOUT2                                                    15540000
         LH    2,MLSCT(1)          SET UP TO OUTPUT SEVERAL VALUES.     15910000
         LA    1,MLSORG-M(1)       R1 IS M-RELATIVE POINTER TO MPTR     16280000
         LTR   2,2                 OF FIRST ITEM.                       16650000
         BZ    GO2                 EXIT IMMEDIATELY IF LIST IS EMPTY    17020000
*                                                                       17390000
*              REENTRY TO PROCESS NEXT LIST ELEMENT.                    17760000
*              R1 = M-RELATIVE ADDRESS OF NEXT ENTRY IN LIST M-ENTRY    18130000
*              R2 = COUNT OF REMAINING ENTRIES IN LIST                  18500000
GOUT1    ST    1,LEAD              SAVE ADDRESS OF CURRENT MPTR         18870000
         L     1,M(1)              LOOK AT MPTR                         19240000
         LTR   1,1                                                      19610000
         BNM   GOUT2               POSITIVE IS GENUINE MPTR             19980000
         L     1,M(1)              NEGATIVE IS INDIRECT MPTR            20720000
GOUT2    ST    2,LECT              SAVE LIST ENTRY COUNT                21090000
         N     1,QF24BITS          IF MPTR IS ZERO,                     21460000
         BZ    GO8                 LIST ELEMENT IS NULL.  IGNORE IT.    21830000
         LA    2,M(1)              OTHERWISE, MAKE SURE IT ITSELF       22200000
         TM    MLIST-M(2),MLSTBIT  ISN'T A LIST.                        22570000
         BO    SYNTERR                                              G01 22940000
         ST    1,PSVD              SAVE ADDRESS OF PRINTEE              23310000
         SR    2,2                 SET UP INITIALLY                     23680000
         ST    2,WIDTH             FOR ZERO WIDTH (VECTOR) FORMAT       24050000
         ST    2,KCT               AND FIRST DATA ELEMENT               24420000
         IC    2,MTYPE(1)                                               24790000
         ST    2,TYPE              SAVE DATA TYPE                       25160000
         ICALL XRHO                FIND TOTAL NO OF ELEMENTS IN R0, R1  25530000
         LTR   1,1                 IS ARRAY EMPTY --                    25900000
         BZ    GO8                 YES.  PRINT A BLANK LINE (IF ANY).   26270000
         L     4,PSVD                                                   26640000
         LH    3,MRANK(4)          PICK UP RANK OF QUANTITY             27010000
         LA    2,MRHO-M-8(3,4)     COMPUTE ADDRESS OF PENULTIMATE RANK  27380000
*                                  ELEMENT                              27750000
         LA    4,MRHO-M(3,4)       COMPUTE BASE ADDRESS OF DATA         28120000
         L     5,M+4(2)            PICK ULTIMATE RANK ELEMENT           28490000
* * * *        NOTE WELL -- R5 PRESERVED DOWN TO GOLM                   28860000
         LA    6,4                 NEEDED LATER                         29230000
         CR    3,6                 DO WE HAVE A VECTOR OR SCALAR --     29600000
         BNH   GOSV                YES.  PROCESS IT SEPARATELY.         29970000
*              VALUE IS NON-EMPTY ARRAY                                 30340000
         LA    7,0(1,1)            SAVE XRHO TEMPORARILY                30710000
         DR    0,5                 COMPUTE COLUMN LENGTH                31080000
         LR    3,5                 REARRANGE FOR STM                    31450000
         STM   1,4,JCT+4           SAVE COLUMN LENGTH, ADDRESS OF PEN-  31820000
*                                  ULTIMATE RANK ELEMENT, ROW LENGTH,   32190000
*                                  AND DATA ADDRESS.                    32560000
         L     1,TYPE              BRANCHING ON TYPE, FIND WIDTH OF     32930000
         IC    1,GO3-1(1)          PRINTED ELEMENTS.                    33300000
         AR    7,7                 R7 IS JUST UNDER 4 * XRHO            33670000
*                                  R2 IS DATA ADDRESS FOR BXLE LOOPS.   34040000
         BCT   7,GO4(1)            ALWAYS GOES                          34410000
GO4      LA    4,2                 BOOLEAN ARRAY.  WIDTH IS 2.          34780000
         B     GOL                                                      35150000
GO7      LA    4,1                 CHARACTER ARRAY.  WIDTH IS 1.        35520000
         B     GOL                                                      35890000
*              INTEGER ARRAY.  WIDTH OF PRINTED COLUMNS IS NUMBER OF    36260000
*              DIGITS IN LARGEST MAGNITUDE, PLUS 2.                     36630000
GO5      AR    7,4                 SET UP LIMIT FOR BXLE                37000000
         SR    0,0                 NOW SEARCH FOR MAXIMUM MAGNITUDE.    37370000
GO5B     L     1,M(4)              GET NEXT ELEMENT                     37740000
         LPR   1,1                 MAKE IT POSITIVE                     38110000
         CLR   0,1                                                      38480000
         BNL   GO5A                TAKE MAX                             38850000
         LR    0,1                                                      39220000
GO5A     BXLE  4,6,GO5B            BACK FOR THE NEXT.                   39590000
         LA    7,GOP10L-GOP10+7    NOW COMPARE AGAINST POWERSOFTEN      39960000
         LA    4,8                                                      40330000
GO5D     CL    0,GOP10-8(4)                                             40700000
         BL    GO5C                LARGER POWER OF TEN FOUND.           41070000
         BXLE  4,6,GO5D            BACK FOR NEXT OR FALL THROUGH ON 10  41440000
GO5C     SRA   4,2                 GET WIDTH FROM WORD INDEX            41810000
         B     GOL                                                      42180000
GOP10    DC    F'1,10,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9'                  42550000
GOP10L   EQU   *                                                        42920000
*              FLOATING-POINT ARRAY.                                    43290000
GO6      AR    7,7                 MAKE R7 DOUBLEWORD DATA LENGTH       43660000
         AR    7,4                 NOW R7 IS BXLE LIMIT                 44030000
         AR    6,6                 R6 = 8                               44400000
         SDR   0,0                 PREPARE TO FIND MAXIMUM AND MINIMUM  44770000
         LE    0,GOE1                                                   45140000
         LD    4,GOD1016           ABSOLUTE VALUES, EXCLUDING ZERO.     45510000
         LDR   6,4                 NEEDED IN MAGNITUDE DETERMINATION    45880000
GO6B     LA    1,M(4)                                                   46250000
         LM    0,1,0(1)            DATA ELEMENT                         46620000
         STM   0,1,DTEMP                                                46990000
         LD    2,DTEMP                                                  47360000
         LPER  2,2                 TAKE ABSOLUTE VALUE                  47730000
         BZ    GO6A                IGNORE ZEROES                        48100000
         CDR   0,2                 CARRY MAXIMUM VALUE IN D0            48470000
         BNL   *+6                                                      48840000
         LDR   0,2                                                      49210000
         CDR   4,2                 CARRY MINIMUM NONZERO VALUE IN D4    49580000
         BNH   GO6A                                                     49950000
         LDR   4,2                                                      50320000
GO6A     BXLE  4,6,GO6B                                                 50690000
         LA    4,21                MAGNITUDE DETERMINATION.             51060000
GO6F     CDR   0,6                 COMPARE MAX MAGNITUDE AGAINST        51430000
         BNL   GO6C                SUCCESSIVELY SMALLER POWERS OF TEN   51800000
         DD    6,GOD10             (SLOWER THAN A TABLE BUT FAR SHORTER 52170000
         BCT   4,GO6F              )                                    52540000
         B     GO6EF               MAX MAGNITUDE TOO SMALL -- LSS 1E-4  52910000
GO6C     LR    2,4                 SAVE MAX MAGNITUDE                   53280000
GO6E     CDR   4,6                 REPEAT THE PROCESS FOR MIN MAGNITUDE 53650000
         BNL   GO6D                                                     54020000
         DD    6,GOD10                                                  54390000
         BCT   4,GO6E                                                   54760000
*              MIN MAGNITUDE FALLS THROUGH, DETECTED AS WIDE SPREAD     55130000
GO6D     S     2,QF5               GET TRUE POWER OF TEN                55500000
         C     2,OSIGDIG                                                55870000
         BNL   GO6EF               TOO BIG -- GEQ 10**OSIGDIG           56240000
         SR    2,4                                                      56610000
         BNM   GO6EF               SPREAD TOO WIDE -- GTR 4 ORDERS      56980000
         S     4,QF5               MIN MAGNITUDE PLACES THE DECIMAL PT  57350000
         SLL   4,16                                                     57720000
         B     GO6W                                                     58090000
GO6EF    L     4,=A(X'F80000')     BYTE 1 WILL BE X'FF'                 58460000
GO6W     AH    4,OSIGDIG+2         INSERT FIELD WIDTH                   58830000
         A     4,=A(X'070007')     PLUS 7 FOR SIGN AND EXPONENT         59200000
GOL      STH   4,MAXWIDTH                                               59570000
         ST    4,WIDTH                                                  59940000
         ICALL LOUTI               TRACE & MIXED OUTPUT LEAVE JUNK      60310000
         B     GOLN                DON'T PRECEED MAXRIX BY BLANK LINE   60680000
GOSV     EQU   *                   SET UP TO OUTPUT SCALAR OR VECTOR    61050000
         LR    0,1                 REARRANGE FOR STM                    61420000
         LA    1,1                 STORE ELEMENT COUNT, ROW COUNT,      61790000
         STM   0,4,JCT             GARBAGE, AND BASE ADDRESS OF DATA.   62160000
         SR    2,2                 SET UP MAXIMUM WIDTH                 62530000
         TRT   TYPE+3(1),MWPT-1                                         62900000
         BNE   GOSV1               FLOATING-POINT HANDLED SEPARATELY    63270000
         L     2,OSIGDIG                                                63640000
         LA    2,6(2)              IT'S MAX NO. OF DIGITS PLUS SIX.     64010000
GOSV1    STH   2,MAXWIDTH                                               64380000
         B     GOL3                OFF TO THE OUTPUT LOOP --            64750000
*              LOOP ENTRY FOR MULTIDIMENSIONAL ARRAYS                   65120000
GOL1     ST    3,ICT               WE JUST FINISHED A ROW OF AN ARRAY.  65490000
GOLF     SR    2,2                 FOR EACH PLANE, CUBE ETC OF WHICH    65860000
         D     2,M(4)              THIS IS AN END                       66230000
         S     4,QF4               (DETERMINED BY NUMBER OF TRAILING    66600000
         LTR   2,2                 0'S IN SUBSCRIPT LIST OF NEXT ELEM), 66970000
         BNZ   GOLM                                                     67340000
         LA    1,QZLFIDL           PRINT AN EXTRA SPACE.                67710000
         ICALL SQUIRT                                                   68080000
         B     GOLF                                                     68450000
GOLM     BAL   6,LINE              FORCE OUT THIS ROW.                  68820000
GOLN     LR    2,5                 SET UP COLUMN COUNTER                69190000
*              TOP OF VECTOR AND ROW DISPLAY LOOP                       69560000
GOL2     ST    2,JCT                                                    69930000
         CLI   TYPE+3,4            IF THIS IS NOT CHARACTER TYPE,       70300000
         BE    GOL3                                                     70670000
         CLI   WIDTH+3,0           AND WE ARE OUTPUTTING A VECTOR,      71040000
         BNE   GOL3                                                     71410000
         LA    1,Q2BL              THEN PRINT TWO BLANKS.               71780000
         ICALL SQUIRT                                                   72150000
GOL3     LH    1,OBUFPTR           CHECK TO SEE THAT WE'RE WELL AWAY    72520000
         AH    1,MAXWIDTH          FROM THE RIGHT MARGIN.               72890000
         CH    1,OBUFLIM           IF THE NEXT ELEMENT COULD RUN OVER   73260000
         BNH   GOL4                THE MARGIN,                          73630000
         BAL   6,LINE              CLOSE THIS LINE.                     74000000
         LA    1,INDENT            AND START A CONTINUATION LINE        74370000
         ICALL SQUIRT              INDENTED SIX SPACES.                 74740000
GOL4     LM    2,3,KCT             SET UP FOR ELEMENT FETCH.            75110000
         LA    0,1(2)              BUMP THE ELEMENT COUNTER TO THE      75480000
         ST    0,KCT               FOLLOWING ELEMENT.                   75850000
         L     4,BASE                                                   76220000
         ICALL FETCH               PUT NEXT ELEMENT IN DTEMP            76590000
         STM   0,1,DTEMP                                                76960000
         CLI   TYPE+3,4            CHARACTER OUTPUT NEEDS EXTRA CARE    77330000
         BNE   GOL5                                                     77700000
         CLI   DTEMP,ZCR                                                78070000
         BNE   GOL5                                                     78440000
         BAL   6,LINE                                                   78810000
         B     GOL6                                                     79180000
GOL5     LM    2,3,TYPE            SET UP ARGUMENTS FOR BCD CONVERT.    79550000
         ICALL TOBCD               DO THE CONVERSION AND PUT RESULT IN  79920000
*                                  THE OUTPUT BUFFER.                   80290000
GOL6     LM    2,5,JCT             PICK UP VARIOUS COUNTERS ETC         80660000
         BCT   2,GOL2              BACK FOR MORE IF ROW NOT FINISHED    81030000
*                                  FINISHED.                            81400000
         BCT   3,GOL1              BRANCH ON ROW COUNT (COL LENGTH)     81770000
*                                  TO END-OF-ROW LOGIC.                 82140000
GO8      LM    1,2,LEAD            RECALL LIST ADDRESS AND COUNT        82510000
         LA    1,4(1)              BUMP ADDRESS TO NEXT LIST ELMENT     82880000
         BCT   2,GOUT1                                                  83250000
*  QUADP OUTPUT IS NOT TO BE GIVEN SPECIAL TREATMENT AS IN THE PAST A05 83620000
DSECT2   DSECT                                                      A05 83990000
         CLI   SYL+1,1+2*ZQUADP    QUAD-PRIME OUTPUT DOESN'T FORCE A CR 84360000
         BE    GO2                                                      84730000
GOUT     CSECT                                                      A05 85100000
GO9      BAL   6,LINE                                                   85470000
GO2      IRETURN                                                        85840000
LINE     ICALL LOUT                PRINT THIS LINE.                     86210000
         ATT   ON=GO2,RESET=NO     DISCONTINUE OUTPUT IF ATTENTION IS   86580000
         BR    6                   SET, BUT DON'T CLEAR IT.             86950000
SYNTERR  LA    1,ESYNTAX           WE CAN'T HANDLE MULTILEVEL TESTS G01 87320000
         ICALL ERROR                                                    87690000
GO3      DC    AL1(GO4-GO4,GO5-GO4,GO6-GO4,GO7-GO4) ARRAY SETUP ADDRS   88060000
MWPT     DC    FL1'3,13,0,1'       MAXIMUM WIDTHS OF DISPLAY ITEMS      88430000
INDENT   DC    AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK)         88800000
Q2BL     DC    AL1(2,ZBLANK,ZBLANK)                                     89170000
QZLFIDL  DC    AL1(2,ZLF,ZILG)     LINEFEED AND IDLE CHAR (TIMING)      89540000
QF4      DC    F'4'                                                     89910000
QF24BITS DC    A(X'FFFFFF')                                             90280000
QF5      DC    F'5'                                                     90650000
GOE1     DC    E'1'                                                     91020000
GOD10    DC    D'10'                                                    91390000
GOD1016  DC    D'1E16'                                                  91760000
         LTORG                                                          92130000
GOUL     DSECT                                                          92500000
DTEMP    DS    D                                                        92870000
PSVD     DS    F                   PTR TO M-ENTRY BEING PRINTED         93240000
JCT      DS    5F                  REMAINING ELEMENTS IN THIS ROW       93610000
ICT      EQU   JCT+4               REMAINING ROWS IN ARRAY              93980000
PRBASE   EQU   JCT+8               ADDRESS OF PENULTIMATE RANK ELEMENT  94350000
COLNOS   EQU   JCT+12              NUMBER OF COLUMNS IN ARRAY (ROW LGT) 94720000
BASE     EQU   JCT+16              DATA BASE ADDRESS                    95090000
KCT      DS    3F                  ELEMENT COUNT (1ST ARG TO FETCH)     95460000
TYPE     EQU   KCT+4               TYPE (2ND ARG TO FETCH (AND TOBCD))  95830000
WIDTH    EQU   KCT+8               CONTROL INFO (3RD ARG TO TOBCD)      96200000
MAXWIDTH DS    H                                                        96570000
LEAD     DS    2F                  LIST ENTRY ADDRESS (M-REL)           96940000
LECT     EQU   LEAD+4              LIST ENTRY COUNT (=1 FOR NONLIST)    97310000
GOULND   EQU   *                                                        97680000
         END                                                            98050000
./  ADD    NAME=APLSGRAD
GRAD     TITLE 'S O R T  --  G R A D E   U P   +   D O W N    05/11/70' 00430000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00860000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01290000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01720000
         PRINT OFF       APLDEFN, OPSECT                                02150000
EXMSORT  CSECT                                                          03010000
         COPY APLDEFN                                                   03440000
         COPY  OPSECT                                                   03870000
         TITLE 'S O R T  --  G R A D E   U P   +   D O W N    05/11/70' 04300000
         PRINT ON,NOGEN                                                 04730000
         ENTRY EXUPGRD                                                  05160000
         ENTRY EXDNGRD                                                  05590000
         EXTRN ERROR                                                    06020000
         EXTRN OPSPACE                                                  06450000
EXMSORT  CSECT                                                          06880000
XZI      EQU   0                                                        07310000
ZI       EQU   9                                                        07740000
R1       EQU   1                                                        08170000
R        EQU   2                                                        08600000
I        EQU   3                                                        09030000
ZR       EQU   4                                                        09460000
ZERO     EQU   5                                                        09890000
DECIDE   EQU   6                                                        10320000
XBASE    EQU   7                                                        10750000
ZBASE    EQU   8                                                        11180000
COMPARE  EQU   10                  THIS IS THE COMPARE ADDRESS.         11610000
         USING OPSECT-16,LR                                             12040000
         USING X1,XBASE                                                 12470000
         USING Z1,ZBASE                                                 12900000
         USING *,9                                                      13330000
EXUPGRD  LA    1,ASCEND-1          THIS IS TO GET THE COMPARE ADDRESS.  13760000
         BC    15,COUPLE                                                14190000
         USING *,9                                                      14620000
EXDNGRD  LA    1,DESCEND-1         GET THE COMPARE ADDRESS.             15050000
COUPLE   ST    PR,FTEMP            SAVE CALLER'S BASE REGISTER          15480000
         BALR  PR,0                GRAB IT FOR LOCAL USE                15910000
         USING *,PR                                                     16340000
ORG      EQU   *                                                        16770000
         ST    LKR,DBLSAVE         DOUBLY SAVE LKR.                     17200000
         L     2,RHTYPE            INPUT TYPE. 1, 2, OR 3.              17630000
         IC    2,0(1,2)            SNATCH AN OFFSET FOR LATER.          18060000
         ST    2,DTEMP             STASH IT AWAY IN A SAFE PLACE.       18490000
         L     1,RHXRHO            GET THE NUMBER OF THINGS THERE.      18920000
         LA    2,4                 IT MUST BE A VECTOR.                 19350000
         C     2,RHRANK            IT MUST BE A VECTOR.                 19780000
         BC    8,AWRIGHT           BRANCH IF IT IS OKAY.                20210000
         LA    R1,ERANK                                                 20640000
         ICALL ERROR                                                    21070000
AWRIGHT  EQU   *                                                        21500000
         LA    3,2                 INTEGER TYPE.                        21930000
         L     10,=A(OPSPACE)      NOW GET SOME PLACE TO PUT THE ANS.   22360000
         BALR  LKR,10              XX                                   22790000
         L     XBASE,RHBASE        EXTABLISH A BASE FOR X.              23220000
         LR    ZBASE,1             LOAD THE RESULT BASE.                23650000
         QUEND                                                          24080000
         LR    COMPARE,12          GET THE REAL COMPARE ADDRESS.        24510000
         A     COMPARE,DTEMP       XX                                   24940000
         AR    XBASE,MR            MAKE THOSE THINGS ABSLOUTELY         25370000
         AR    ZBASE,MR            ACCESSIBLE.                          25800000
         MVC   MTYPE-M(8,ZBASE),MTYPE-M(XBASE) MOVE IN THE RANK VECTOR. 26230000
         MVI   MTYPE-M(ZBASE),X'02'                                     26660000
         L     I,MRHO-M(XBASE)     GET THE NUMBER OF THINGS IN X.       27090000
         LA    R,4                                                 2.75 27520000
         LR    ZR,R                                                2.50 27950000
         L     0,X800              X'80000000'                          28380000
         BXLE  I,I,CLEAN           DOUBLE I AND TEST FOR IOTA ZERO.4.50 28810000
         CLI   MTYPE-M(XBASE),X'01'  BIT OPERANDS ARE DONE SEPARATELY.  29240000
         BC    8,BITTYS            SO GO DO IT IF IT IS BITS.           29670000
         BCTR  I,0                 SUBTRACT ONE FOR BXLE.          3.25 30100000
TAG1     ALR   0,R                                                 3.25 30530000
         ST    0,Z(ZR)                                             4.50 30960000
         BXLE  ZR,R,TAG1                                           5.50 31390000
         BCT   I,TAG3              BRANCH IF NOT ONE ELEMENT.      4.50 31820000
         BC    15,T6               X HAS ONE ELEMENT, TAKE CARE OF IT.  32250000
CMPAI    L     XZI,X(ZI)           COMPARE X(ZI) TO X(ZR).              32680000
         C     XZI,X(ZR)           SET THE CONDITION CODE ACCORDINLY.   33110000
         BCR   7,LKR               EXIT IF NOT EQUAL.                   33540000
         CR    ZI,ZR               OTHERWISE, COMPARE THE RELATIVE      33970000
         BCR   15,LKR              POSITIONS IN X TO DETERMINE ORDER.   34400000
CMPDI    L     0,X(ZR)             COMPARE X(ZR) TO X(ZI).              34830000
         C     0,X(ZI)                                                  35260000
         BCR   7,LKR                                                    35690000
         CR    ZI,ZR                                                    36120000
         BCR   15,LKR                                                   36550000
CMPAF    LA    1,X-4(ZI)           GET AN ABSOLUTE ADDRESS FOR MVC.     36980000
         AR    1,ZI                                                     37410000
         MVC   DTEMP(8),0(1)       ALIGN TO DOUBLEWORD                  37840000
         LD    0,DTEMP                                                  38270000
         LA    1,X-4(ZR)           GET AN ABSOLUTE ADDRESS FOR MVC.     38700000
         AR    1,ZR                                                     39130000
         MVC   DTEMP(8),0(1)                                            39560000
         CD    0,DTEMP                                                  39990000
         BCR   7,LKR                                                    40420000
         CR    ZI,ZR                                                    40850000
         BCR   15,LKR                                                   41280000
CMPDF    LA    1,X-4(ZR)           GET AN ABSOLUTE ADDRESS FOR MVC.     41710000
         AR    1,ZR                                                     42140000
         MVC   DTEMP(8),0(1)                                            42570000
         LD    0,DTEMP                                                  43000000
         LA    1,X-4(ZI)           GET AN ABSOLUTE ADDRESS FOR MVC.     43430000
         AR    1,ZI                                                     43860000
         MVC   DTEMP(8),0(1)       A0707                                44290000
         CD    0,DTEMP                                                  44720000
         BCR   7,LKR                                                    45150000
         CR    ZI,ZR                                                    45580000
         BCR   15,LKR                                                   46010000
CMPAB    BC    3,BITTY4            BRANCH IF THERE IS A CARRY.          46440000
CMPDB    BC    12,BITTY4           BRANCH IF THERE WAS NO CARRY.        46870000
         BC    12,BITTY4           BRANCH IF THERE WAS NO CARRY.        47300000
         BC    3,BITTY4            BRANCH IF THERE IS A CARRY.          47730000
*********************************************************************** 48160000
* THIS PART OF THE PROGRAM SORTS A VECTOR OF TYPE ONE, A BIT ARRAY. *** 48590000
* THE REGISTER USAGE IS AS FOLLOWS.....                             *** 49020000
* XZI -- REGISTER R0 .. WORKING REGISTER FOR THE NEXT 32 BITS OF X. *** 49450000
* R1 .. A COUNTER FROM 32 DOWN TO ZERO, FOR REFILLING R0.           *** 49880000
* R  .. THIS REGISTER CONTAINS A ONE.                               *** 50310000
* I .. LIMIT FOR BXLE, = IORIGIN + #ELEMENTS -1.                    *** 50740000
* ZR .. INDEX OF NEXT RESULT WORD.                                  *** 51170000
* ZI .. INDEX OF CURRENT INPUT WORD.                                *** 51600000
* ZERO .. CONTRARY TO ITS LABEL, THIS CONTAINS A FOUR FOR THIS PART.*** 52030000
* DECIDE .. CURRENT INPUT INDEX. (STARTS AT IORIGIN).               *** 52460000
* COMPARE .. THE ADDRESS OF THE BC FOR COMPARING CORRECTLY.         *** 52890000
*********************************************************************** 53320000
BITTYS   LR    ZERO,R              HERE I PUT A FOUR IN ZERO.           53750000
BITTY    L     I,MRHO-M(XBASE)     GET THE NUMBER OF ELEMENTS IN X.     54180000
         BCTR  I,0                 SUBTRACT ONE.                        54610000
         L     DECIDE,IORIGIN      THE INDEX ORIGIN.                    55040000
         AR    I,DECIDE            CAUSE I TO BE CORRECT INITIALLY.     55470000
         LA    R,1                 NOW PUT A ONE IN R.                  55900000
         LR    ZI,ZERO             MAKE ZI A FOUR.                      56330000
         LR    R1,R                AVOID THE FIRST BCT.                 56760000
BITTY1   BCT   R1,BITTY2           BRANCH IF THE COUNT IS NOT OVER.     57190000
         SR    XBASE,MR            HERE I LET THE OTHER GUYS GET A      57620000
         SR    ZBASE,MR            CHANCE TO DO SOMETHING.              58050000
         QUEND                                                          58480000
         AR    XBASE,MR            ADD BACK THE WORKSPACE BASE.         58910000
         AR    ZBASE,MR            ADD BACK THE WORKSPACE BASE.         59340000
         LA    R1,32               GET THE COUNT READY.                 59770000
         L     XZI,X(ZI)           PUT THE 32 BITS IN THE REGISTER.     60200000
         AR    ZI,ZERO             ADD FOUR TO ZI.                      60630000
BITTY2   ALR   XZI,XZI             DOUBLE THE REGISTER AND TEST THE     61060000
         EX    0,0(COMPARE)        OVERFLOW BIT TO SEE IF IT WAS A ZERO 61490000
BITTY3   ST    DECIDE,Z(ZR)        OR A ONE.  THEN STORE THE INDEX      61920000
         AR    ZR,ZERO             WHEN APPROPRIATE AND EKE ZR.         62350000
BITTY4   BXLE  DECIDE,R,BITTY1     KEEP GOING UNTIL X IS EXHAUSTED.     62780000
         LA    COMPARE,8(COMPARE)  THIS IS A SNEAKY WAY TO REVERSE      63210000
         CLI   0(COMPARE),X'47'    THE COMPARISON FOR THE NEXT TIME     63640000
         BC    8,BITTY             THROUGH THE LOOP AND AT THE SAME     64070000
         BC    15,CLEAN            TIME TEST FOR THE END OF THE DOUBLE  64500000
*                                  LOOP. X'47' IS THE OP CODE FOR BC.   64930000
ASCEND   DC    AL1(CMPAB-ORG)      BIT OPERANDS                         65360000
         DC    AL1(CMPAI-ORG)      INTEGER OPERANDS                     65790000
         DC    AL1(CMPAF-ORG)      FLOATING POINT NUMBERS               66220000
DESCEND  DC    AL1(CMPDB-ORG)      DESCENDING BITS                      66650000
         DC    AL1(CMPDI-ORG)      DESCENDING INTEGERS                  67080000
         DC    AL1(CMPDF-ORG)      DESCENDING FLOATING NUMBERS          67510000
TAG3     ALR   I,I                                                 3.25 67940000
TAG2     ST    ZR,Z(ZR)                                            4.50 68370000
         BXLE  ZR,R,TAG2                                           5.50 68800000
         LA    ZI,4(I)             SET ZI TO INITIAL VALUE.        2.75 69230000
         SR    ZERO,ZERO                                           3.25 69660000
         BAL   DECIDE,T0           SET UP DECIDE TO GO TO EXCNOT.       70090000
EXCNOT   ST    ZI,Z(R)                                             4.50 70520000
         LR    ZI,ZR                                               2.50 70950000
         AL    ZI,X800                                                  71380000
         SR    XBASE,MR            RELATIVIZE NICELY                    71810000
         SR    ZBASE,MR            IN CASE OF QUANTUM END               72240000
         QUEND                                                          72670000
         AR    XBASE,MR                                                 73100000
         AR    ZBASE,MR                                                 73530000
         BXH   R,R,T3                                              5.50 73960000
T0       EQU   *                                                        74390000
T1       L     ZR,Z(R)                                             4.50 74820000
         BXH   ZR,ZERO,T2                                          5.50 75250000
         LA    R,2(R)                                              2.75 75680000
T2       BXLE  R,R,T1                                              5.50 76110000
T3       SRL   R,3                                                 5.50 76540000
         SLL   R,2                                                 5.00 76970000
T3A      L     ZR,Z(R)                                             4.50 77400000
         BXLE  ZR,ZERO,0(DECIDE)                                   5.00 77830000
         BALR  LKR,COMPARE         COMPARE THE NUMBERS.                 78260000
         BC    2,T5                                                3.50 78690000
*              EXCHANGE THE CONTENTS OF Z(I) AND Z(R).  *           .   79120000
T3B      AL    ZI,X800                                                  79550000
T4       ST    ZI,Z(R)                                             4.50 79980000
         LR    ZI,ZR                                               2.50 80410000
T5       SRL   R,3                                                 5.50 80840000
         SLL   R,2                                                 5.00 81270000
         BXH   R,ZERO,T3A                                          5.50 81700000
T5A      SRL   ZI,2                                                5.00 82130000
         A     ZI,IORIGIN                                               82560000
         BCTR  ZI,0                                                     82990000
         ST    ZI,Z2(I)                                            4.50 83420000
         LA    DECIDE,PORDER                                       2.75 83850000
         SR    XBASE,MR                                            3.25 84280000
         SR    ZBASE,MR                                            3.25 84710000
         QUEND                                                          85140000
         AR    XBASE,MR                                            3.25 85570000
         AR    ZBASE,MR                                            3.25 86000000
         S     I,FOUR                                              4.00 86430000
T6       L     ZI,Z2(I)                                            4.50 86860000
         N     ZI,KNOCK                                            5.75 87290000
         LA    R,2                                                 2.75 87720000
         BXLE  R,R,T0                                              5.50 88150000
         SRL   ZI,2                                                5.00 88580000
         A     ZI,IORIGIN                                               89010000
         BCTR  ZI,0                                                     89440000
         ST    ZI,Z+4                                              4.00 89870000
*        END OF SORT, NOW FOR CLEAN UP AND EXIT.*                   .   90300000
CLEAN    L     PR,FTEMP            RESTORE CALLER'S BASE REGISTER       90730000
         L     LKR,DBLSAVE         NOW RETURN TO THE OTHER PROGRAM.     91160000
         BCR   15,LKR                                                   91590000
PORDER   AL    ZR,X800                                                  92020000
         BALR  LKR,COMPARE         COMPARE THE NUMBERS.                 92450000
         BC    4,T4                                                3.50 92880000
         BC    15,T5                                                    93310000
         CNOP  0,4                                                      93740000
FOUR     DC    XL4'00000004'                                            94170000
X800     DC    XL4'80000000'                                            94600000
KNOCK    DC    XL4'7FFFFFFF'       USED TO KNOCK OFF FIRST BIT.         95030000
         LTORG     *                                                    95460000
X1       DSECT                                                          95890000
         DC    XL12'000000000000000000000000'                           96320000
X        DC    XL4'00000000'                                            96750000
Z1       DSECT                                                          97180000
         DC    XL12'000000000000000000000000'                           97610000
Z        DC    XL4'00000000'                                            98040000
Z2       DC    XL4'00000000'       IN GENERAL, THIS IS USED FOR Z(I).   98470000
         END                                                            98900000
./  ADD    NAME=APLSINDX
INDX     TITLE 'INDEX SUBROUTINE, 09-19-67.'                            00060000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00120000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00180000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00240000
         MACRO                                                          00300000
&TAG     BASE  &R,&N                                                    00360000
&TAG     L     &R,&N.(LWX,MR)                                           00420000
         BMW   &R                                                       00480000
         MEND                                                           00540000
         MACRO                                                          00600000
&TAG     BTAB0 &A,&B,&C,&D,&E,&F,&G,&H,&I,&J,&K,&L,&M,&N,&O,&P          00660000
         CNOP  0,4                                                      00720000
&TAG     DC    AL4(TYPERR)         TYPE ERROR.                          00780000
         DC    AL4(TYPERR)         TYPE ERROR.                          00840000
         DC    AL4(TYPERR)         TYPE ERROR.                          00900000
         DC    AL4(TYPERR)         TYPE ERROR.                          00960000
         DC    AL4(TYPERR)         TYPE ERROR.                          01020000
         DC    AL4(&A)                                                  01080000
         DC    AL4(&B)                                                  01140000
         DC    AL4(&C)                                                  01200000
         DC    AL4(&D)                                                  01260000
         DC    AL4(&E)                                                  01320000
         DC    AL4(&F)                                                  01380000
         DC    AL4(&G)                                                  01440000
         DC    AL4(&H)                                                  01500000
         DC    AL4(&I)                                                  01560000
         DC    AL4(&J)                                                  01620000
         DC    AL4(&K)                                                  01680000
         DC    AL4(&L)                                                  01740000
         DC    AL4(&M)                                                  01800000
         DC    AL4(&N)                                                  01860000
         DC    AL4(&O)                                                  01920000
         DC    AL4(&P)                                                  01980000
         MEND                                                           02040000
         MACRO                                                          02100000
&TAG     BTYP  &ROWR,&COLR,&TABLE                                       02160000
&TAG     SR    R1,R1               ZERO OUT R1 FOR THE IC STEPS.        02220000
         IC    R1,MTYPE(&COLR)     PICK UP COLUMN OF BRANCH MATRIX.     02280000
         LR    R0,R1               PREPARE TO GET THE ROW OF IT ALSO.   02340000
         IC    R0,MTYPE(&ROWR)     GET THE ROW OF THE BRANCH MATRIX.    02400000
         SLL   R0,2                MULTIPLY BY FOUR.                    02460000
         AR    R1,R0               ADD TO THE COLUMN NUMBER.            02520000
         SLL   R1,2                MULTIPLY BY FOUR AGAIN.              02580000
         L     R1,&TABLE.(R1)      LOAD THE BRANCH ADDRESS.             02640000
         BCR   15,R1               BRANCH TO THE RIGHT PLACE.           02700000
         MEND                                                           02760000
         MACRO                                                          02820000
&L       BMW   &GPR                                                     02880000
&L       LTR   &GPR,&GPR           SEE IF THIS IS A SMTB PTR.           02940000
         BC    2,BMW&SYSNDX        BRANCH IF IT IS NOT.                 03000000
         L     &GPR,MLIST(&GPR)    LOAD THE ADDRESS OF THE M-ENTRY.     03120000
BMW&SYSNDX N   &GPR,STRIKE         REMOVE THE 8 HIGH ORDER BITS.        03180000
         MEND                                                           03240000
         MACRO                                                          03300000
&TAG     CBC   &R,&F,&C,&TO                                             03360000
&TAG     C     &R,&F.                                                   03420000
         BC    &C,&TO.                                                  03480000
         MEND                                                           03540000
         MACRO                                                          03600000
&TAG     CBTYP &A,&B,&C,&D,&E,&F,&G,&H,&I,&J,&K,&L,&M,&N,&O,&P          03660000
&TAG     SR    R1,R1                                                    03720000
         IC    R1,MTYPE(A)                                              03780000
         LR    R2,R1                                                    03840000
         IC    R2,MTYPE(V)                                              03900000
         SLL   R1,4                                                     03960000
         AR    R1,R2                                                    04020000
         IC    R1,CBT2&SYSNDX-5(R1)                                     04080000
         BC    15,CBT1&SYSNDX.(R1)                                      04140000
CBT2&SYSNDX DC AL1(&A-CBT1&SYSNDX)                                      04200000
         DC    AL1(&B-CBT1&SYSNDX)                                      04260000
         DC    AL1(&C-CBT1&SYSNDX)                                      04320000
         DC    AL1(&D-CBT1&SYSNDX)                                      04380000
         DC    AL1(&E-CBT1&SYSNDX)                                      04440000
         DC    AL1(&F-CBT1&SYSNDX)                                      04500000
         DC    AL1(&G-CBT1&SYSNDX)                                      04560000
         DC    AL1(&H-CBT1&SYSNDX)                                      04620000
         DC    AL1(&I-CBT1&SYSNDX)                                      04680000
         DC    AL1(&J-CBT1&SYSNDX)                                      04740000
         DC    AL1(&K-CBT1&SYSNDX)                                      04800000
         DC    AL1(&L-CBT1&SYSNDX)                                      04860000
         DC    AL1(&M-CBT1&SYSNDX)                                      04920000
         DC    AL1(&N-CBT1&SYSNDX)                                      04980000
         DC    AL1(&O-CBT1&SYSNDX)                                      05040000
         DC    AL1(&P-CBT1&SYSNDX)                                      05100000
CBT1&SYSNDX EQU *                                                       05160000
         MEND                                                           05220000
         MACRO                                                          05280000
&TAG     CRBC  &R1,&R2,&C,&TO                                           05340000
&TAG     CR    &R1,&R2                                                  05400000
         BC    &C,&TO.                                                  05460000
         MEND                                                           05520000
         MACRO                                                          05580000
&TAG     LODBC &R,&F,&C,&TO                                             05640000
&TAG     L     &R,&F.                                                   05700000
         LTR   &R,&R                                                    05760000
         BC    &C,&TO.                                                  05820000
         MEND                                                           05880000
         MACRO                                                          05940000
&TAG     LOOK  &A,&B,&C                                                 06000000
&TAG     DC    0C' '                                                    06060000
         MEND                                                           06120000
         MACRO                                                          06180000
&TAG     LTRBC &R,&C,&TO                                                06240000
&TAG     LTR   &R,&R                                                    06300000
         BC    &C,&TO.                                                  06360000
         MEND                                                           06420000
         MACRO                                                          06480000
&TAG     LWTG                                                           06540000
&TAG     BAL   R2,LWMGLTR          DO THE LTR ON THIS ONE.              06600000
         MEND                                                           06660000
         MACRO                                                          06720000
&TAG     LWCG                                                           06780000
&TAG     BAL   R2,LWMGBCR          START WITH THE BCR.                  06840000
         MEND                                                           06900000
         MACRO                                                          06960000
&TAG     LWUG                                                           07020000
&TAG     BAL   R2,LWMGN            START WITH THE AND OF STRIKE.        07080000
         MEND                                                           07140000
         MACRO                                                          07200000
&LABEL   LWMOV &TO,&FROM,&COUNT,&WORKRG                                 07260000
*LABEL   LWMOV &TO,&FROM,&COUNT,&WORKRG   ALL OPERANDS ARE REGISTERS.   07320000
&LABEL   LR    &WORKRG,R1          GOTTA SAVE R1.                       07380000
         AH    &COUNT,LW2&SYSNDX   ADD A NEGATIVE 257 TO THE COUNT.     07440000
         BC    4,LW4&SYSNDX        IF IT IS MINUS NOW THERE IS 1 MVC.   07500000
         LA    R0,256              NOW WE CAN GO FOR THE BIG LOOP.      07560000
         LA    R1,0(&TO,&COUNT)    GET THE LIMIT FOR THE GOODOLE BXLE.  07620000
LW1&SYSNDX MVC 0(256,&TO),0(&FROM) MOVE 256 BITES.                      07680000
         AR    &FROM,R0            EKE THE SOURCE BY HEX 100.           07740000
         BXLE  &TO,R0,LW1&SYSNDX   TESTING FOR THE END OF THE LOOP.     07800000
         BC    15,LW4&SYSNDX       LOOP IS ALL DONE NOW, GO TO LAST MVC 07860000
LW2&SYSNDX DC  XL2'FEFF'           THIS IS A NEGATIVE 257.              07920000
LW3&SYSNDX MVC 0(0,&TO),0(&FROM)   THIS IS THE LAST MVC.                07980000
LW4&SYSNDX EX  &COUNT,LW3&SYSNDX   EXECUTE THE MVC FOR LAST FRACTION.   08040000
         LR    R1,&WORKRG          RESTORE R1.                          08100000
         MEND                                                           08160000
         MACRO                                                          08220000
&TAG     LWXR  &BAZMRL,&WORKREG                                         08280000
*        GET X/RHO(ARRAY) IN R1.        *                               08340000
&TAG     LH    &WORKREG,MRANK(&BAZMRL)                                  08400000
         AR    &WORKREG,&BAZMRL                                         08460000
         LA    R1,1                                                     08520000
LWXR&SYSNDX M  R0,FIDLDL(&WORKREG,MR)                                   08580000
         S     &WORKREG,INDFOUR                                         08640000
         CR    &BAZMRL,&WORKREG                                         08700000
         BC    4,LWXR&SYSNDX                                            08760000
         MEND                                                           08820000
         MACRO                                                          08880000
&TAG     ZERO1 &R,&F                                                    08940000
&TAG     SR    &R,&R                                                    09000000
         ST    &R,&F.                                                   09060000
         MEND                                                           09120000
         MACRO                                                          09180000
&TAG     ZERO2 &R,&F1,&F2                                               09240000
&TAG     SR    &R,&R                                                    09300000
         ST    &R,&F1.                                                  09360000
         ST    &R,&F2.                                                  09420000
         MEND                                                           09480000
         MACRO                                                          09540000
&TAG     ZERO3 &R,&F1,&F2,&F3                                           09600000
&TAG     SR    &R,&R                                                    09660000
         ST    &R,&F1.                                                  09720000
         ST    &R,&F2.                                                  09780000
         ST    &R,&F3                                                   09840000
         MEND                                                           09900000
         MACRO                                                          09960000
&TAG     ZERO4 &R,&F1,&F2,&F3,&F4                                       10020000
&TAG     SR    &R,&R                                                    10080000
         ST    &R,&F1.                                                  10140000
         ST    &R,&F2.                                                  10200000
         ST    &R,&F3.                                                  10260000
         ST    &R,&F4.                                                  10320000
         MEND                                                           10380000
         PRINT OFF       COPY APLDEFN                                   10500000
INDEX    CSECT                                                          10560000
         COPY  APLDEFN                                                  10620000
         TITLE 'INDEX SUBROUTINE  09-19-67'                             10680000
         PRINT ON,GEN                                                   10740000
         EXTRN ERROR                                                    10800000
         EXTRN FETCH                                                    10860000
         EXTRN FETCHINT                                                 10920000
         EXTRN GETSPACE                                                 10980000
         EXTRN MKGARB                                                   11040000
         EXTRN STORE                                                    11100000
INDEX    CSECT                                                          11160000
         PROLOG INDEXDMY,LWDSECT                                        11220000
ORGY     EQU   *-6                 THIS IS THE BASE ADDRESS.            11280000
*********************************************************************** 11340000
*                       TABLE OF USES OF VARIOUS SYMBOLS.             * 11400000
*********************************************************************** 11460000
* SYMBOL       CONTENTS OR USE                                        * 11520000
*---------------------------------------------------------------------* 11580000
* SUM    CURRENT RELATIVE ADDRESS OF ELEMENT IN ARRAY BEING INDEXED.  * 11640000
* IORIGIN      THE INDEX ORIGIN IN USE IN THE SYSTEM.                 * 11700000
*********************************************************************** 11760000
R0       EQU   0                                                        11820000
R1       EQU   1                                                        11880000
R2       EQU   2                                                        11940000
R3       EQU   3                                                        12000000
R4       EQU   4                                                        12060000
R5       EQU   5                                                        12120000
R6       EQU   6                                                        12180000
R7       EQU   7                                                        12240000
R8       EQU   8                                                        12300000
R9       EQU   9                                                        12360000
R10      EQU   10                                                       12420000
LWX      EQU   15                                                       12480000
SVIA     EQU   4                                                        12540000
SVIA1    EQU   SVIA+4                                                   12600000
SVIA2    EQU   SVIA+8                                                   12660000
SVIA3    EQU   SVIA+12                                                  12720000
SVIA4    EQU   SVIA+16                                                  12780000
SVIX     EQU   8                                                        12840000
SVIX1    EQU   SVIX+4                                                   12900000
SVIX2    EQU   SVIX+8                                                   12960000
SVIX3    EQU   SVIX+12                                                  13020000
SVIX4    EQU   SVIX+16                                                  13080000
SVIV     EQU   12                                                       13140000
SVIV1    EQU   SVIV+4                                                   13200000
SVIV2    EQU   SVIV+8                                                   13260000
SVIV3    EQU   SVIV+12                                                  13320000
EI3      EQU   R1                                                       13380000
VK       EQU   R2                                                       13440000
VCMPS0   EQU   R2                                                       13500000
VCMPS1   EQU   R3                                                       13560000
JK       EQU   R5                                                       13620000
JI       EQU   R6                                                       13680000
WK       EQU   R6                                                       13740000
SUM      EQU   R7                                                       13800000
ONEREG   EQU   R8                                                       13860000
I        EQU   R8                                                       13920000
A        EQU   R9                                                       13980000
V        EQU   R10                                                      14040000
LOOPRG   EQU   15                                                       14100000
SON      EQU   X'FF'                                                    14160000
         MVI   S,0                                                      14220000
         L     LWX,SVI                                                  14280000
         LTR   R1,R1                                                    14340000
         BC    7,INDXA                                                  14400000
         MVI   S,X'FF'                                                  14460000
         L     A,4(LWX,MR)                                              14520000
         C     A,12(LWX,MR)                                             14580000
         BC    7,INDXA                                                  14640000
* VALUE IS THE SAME AS A, COPY A TO AN UNNAMED ARRAY FOR VALUE. *       14700000
         L     A,M(A)                                                   14820000
         L     R1,4(A,MR)                                               14940000
         LR    R2,R1                                                    15000000
         ICALL GETSPACE                                                 15060000
         L     LWX,SVI                                                  15120000
         O     R1,FOURCON          FLAG THIS AS A TEMPORARY RESULT.     15180000
         ST    R1,12(LWX,MR)                                            15240000
         L     R4,4(LWX,MR)                                             15360000
         BAL   R6,LWMOVES                                               15420000
         LA    R4,12(LWX)                                               15480000
         ST    R4,0(R1,MR)                                              15540000
INDXA    EQU   *                                                        15600000
         QUEND IF ANYBODY WANTS IT, NOW IS THE TIME TO GET IT.          15660000
         LOOK  'INDXA, STACK.',4(LWX),15(LWX)                           15720000
         L     A,4(LWX,MR)         BASE A AND SEE IF IT IS              15780000
         LTR   A,A                 AN UNDEFINED SYMBOL.                 15840000
         BC    2,INDXB             XX                                   15900000
         L     A,M(A)              XX                                   16020000
         LTR   A,A                 XX                                   16080000
         BC    8,VALUERR           XX                                   16140000
INDXB    DS    0H                                                       16200000
         LOOK  'A',M(A),M+63(A)                                         16260000
         L     I,8(LWX,MR)         I CANNOT CURRENTLY BE NAMED.         16320000
         LOOK  'I',M(I),M+63(I)    A228J                                16440000
         LH    R6,MRANK(A)         SET R6 TO RHO RHO A TIMES 4.         16500000
         LA    R4,4                IN GENERAL, R4 ALWAYS CONTAINS A 4.  16560000
         LH    R5,MRANK(I)         NOW LET'S SEE HOW MANY LIST ELEMENTS 16620000
         SLL   R5,2                WE HAVE. IT SHOULD BE THE SAME AS    16680000
         CR    R6,R5               THE NUMBER OF DIMENSIONS OF A.       16740000
         BC    7,RNKERR            RANK ERROR.                          16800000
         C     R6,=A(VK1)          MORE THAN 15 DIMENSIONS              16860000
         BNL   NONCERR             IS NONCE ERROR -- NOT ENOUGH STACK.  16920000
         SPACE 2                                                   6002 16980000
*                                                                  6002 17040000
*        VALIDITY-CHECK THE ARRAY BEING SUBSCRIPTED.               6002 17100000
*        THE FOLLOWING TESTS ARE MADE:                             6002 17160000
*              1.   DOES THE LENGTH OF THE M-ENTRY, AS INDICATED   6002 17220000
*                   BY MCOUNT, AGREE WITH THE PRODUCT OF THE       6002 17280000
*                   ARRAY'S DIMENSIONS AND ITS DATA TYPE.          6002 17340000
*              2.   IS THE MCOUNT FIELD SUCH THAT THE END OF THE   6002 17400000
*                   M-ENTRY WOULD BE BEYOND MX.                    6002 17460000
*              3.   DOES AN OVERFLOW OCCUR INTO THE HIGH ORDER     6002 17520000
*                   REGISTER WHILE TAKING THE PRODUCT OF THE       6002 17580000
*                   ARRAY'S DIMENSIONS.                            6002 17640000
*        VIOLATORS ARE GIVEN A DOMAIN ERROR.                       6002 17700000
*                                                                  6002 17760000
         MVI   OFLOWSW,X'00'       INITIALIZE OVERFLOW SWITCH      6002 17820000
         LR    VCMPS0,R6           4 TIMES RANK OF A               6002 17880000
         LA    VCMPS1,0(A,MR)      ABSOLUTIZE A                    6002 17940000
         TM    0(VCMPS1),MLSTBIT   CANNOT INDEX A LIST             6002 18000000
         BO    SYNTERR                                             6002 18060000
         SR    R1,R1                                               6002 18120000
         IC    R1,MTYPE(A)         GET BITS PER ELEMENT,           6002 18180000
         IC    R1,RIGHTBYT-1(R1)    BASED ON MTYPE                 6002 18240000
VALID1   M     R0,MRHO-M-4(VCMPS0,VCMPS1)  TIMES / RHO A           6002 18300000
         LTR   R0,R0                                               6002 18360000
         BNZ   VALID2                                              6002 18420000
         LTR   R1,R1                                               6002 18480000
         BNM   VALID3                                              6002 18540000
VALID2   MVI   OFLOWSW,X'FF'       MULTIPLY HAS OVERFLOWED --FLAG  6002 18600000
         L     R1,STRIKE           ASSURE A NON-ZERO MULTIPLICAND  6002 18660000
VALID3   SR    VCMPS0,R4           DECREMENT MRHO INDEX            6002 18720000
         BP    VALID1              FALL THRU AT END OF MRHO        6002 18780000
         CLI   OFLOWSW,X'FF'       HAS OVERFLOW BEEN FLAGGED       6002 18840000
         BNE   VALID4              NO.                             6002 18900000
         OR    R0,R1               YES.  DOMAIN ERROR IF PRODUCT   6002 18960000
         BNZ   TYPERR               NOT 0.                         6002 19020000
VALID4   A     R1,=F'31'           ROUNDUP TO WORD BOUNDARY        6002 19080000
         SRL   R1,5                CONVERT BITS TO WORDS           6002 19140000
         SLL   R1,2                CONVERT WORDS TO BYTES          6002 19200000
         AR    R1,R6               ADD LENGTH OF RANK VECTOR       6002 19260000
         LA    VCMPS0,MRHO-M                                       6002 19320000
         AR    R1,VCMPS0           ADD LENGTH OF STANDARD INFO     6002 19380000
         C     R1,MCOUNT(A)        VALIDATE AGAINST M-ENTRY LGTH   6002 19440000
         BNE   TYPERR                                              6002 19500000
         LA    R1,0(R1,A)                                          6002 19560000
         CL    R1,MX               DOES M-ENTRY END UP BEYOND MX   6002 19620000
         BH    TYPERR              YES                             6002 19680000
         SPACE 2                                                   6002 19740000
         TM    S,SON                                                    19800000
         BC    7,INDX1A                                                 19860000
         CR    R4,R6               SEE IF A IS A VECTOR, AND IF SO      19920000
         BC    8,AISVEC            TREAT THAT AS A SPECIAL CASE.        19980000
INDX1A   EQU   *                                                        20040000
IND2     EQU   *                                                        20100000
         ST    A,AS                SAVE THIS ADDRESS FOR LATER.         20160000
         ST    I,IS                AND THIS ONE.                        20220000
         LA    R0,WK1              SET UP WKS FOR THE FIRST TIME.       20280000
         ST    R0,WKS              XX                                   20340000
         LA    R0,VK1              SIMILARLY, SET UP VKS                20400000
         ST    R0,VKS              XX                                   20460000
         SR    SUM,SUM             THIS REGISTER IS MAINTAINED ALL      20520000
*                                  THE WAY THROUGH TO THE END.          20580000
         ST    SUM,SCRAM           ZERO OUT THE CHECK SUM.              20640000
         LA    R1,1                SET UP A FEW OTHER THINGS NOW.       20700000
         ST    R1,ACMPS            XX                                   20760000
         ST    R1,VCMPS            XX                                   20820000
         AR    A,R5                GET SET FOR THE BIG LOOP.            20880000
         AR    I,R5                A IS USED FOR LOOP CONTROL.          20940000
INDX2    EQU   *                   HERE IT IS, THE BIG LOOP.            21000000
         LOOK  'INDX2, DSECT.',FUG1,FUG2                                21060000
         SR    A,R4                                                     21120000
         SR    I,R4                                                     21180000
*                                  IN THIS SECTION I CALCULATE THINGS   21240000
*                                  IN THE MATRIX E FOR USE IN THE REAL  21300000
*                                  INDEXING LOOP. ALSO I FIGURE OUT     21360000
*                                  HOW MUCH SPACE TO ALLOCATE FOR V.    21420000
         L     JK,MRHO(I)          JK CARRIES THE M-RELATIVE ADDRESS    21480000
         LTR   JK,JK               OF THE M-ENTRY THAT CORRESPONDS TO   21540000
         BC    2,INDX3A            THE CURRENT LIST ENTRY, M(I).        21600000
         BC    4,INDX3             BRANCH IF IT IS NAMED.               21660000
*                                  HERE THE LIST ELEMENT WAS EMPTY, SO  21720000
         L     VCMPS1,MRHO(A)      USE THE MATCHING COMPONENT OF RHO A  21780000
         L     VK,VKS              VK IS THE CURRENT SUBSCRIPT FOR F,   21840000
         ST    VCMPS1,F(VK)        WHICH IS USED TO COLLECT THE RANK    21900000
*                                  VECTOR FOR THE RESULT, V, SO THAT I  21960000
*                                  WONT HAVE TO GO THROUGH THIS BIG     22020000
*                                  LOOP MORE THAN ONCE.                 22080000
         SR    VK,R4               THIS LOOP IS A RIGHT TO LEFT SCAN.   22140000
         ST    VK,VKS              VKS IS USED TO HOLD VK WHEN THERE    22200000
*                                  IS NO REGISTER AVAILABLE FOR IT.     22260000
         C     VCMPS1,ONE          IF THE NUMBER OF COMPONENTS IN ANY   22320000
         BC    8,INDX7             GIVEN SUBSCRIPT POSITION IS ONE,     22380000
*                                  THEN I DONT MAKE ANY ENTRIES IN THE  22440000
*                                  MATRIX E FOR IT. INSTEAD, I PROCESS  22500000
*                                  THAT SUBSCRIPT DIRECTLY, AND FIX     22560000
*                                  SUM TO REFLECT THIS CASE.            22620000
         L     WK,SCRAM            SCRAMBLE.                            22680000
         ALR   WK,WK               XX                                   22740000
         XR    WK,VCMPS1           XX                                   22800000
         ST    WK,SCRAM            XX                                   22860000
         L     WK,WKS              WK IS THE INDEX FOR THE CURRENT      22920000
         ST    JK,E(WK)            ROW IN E. JK IS NOW A ZERO.          22980000
         ST    JK,E+8(WK)          MAKE THESE TWO COLUMNS ZERO.         23040000
         BC    15,INDX5            THEN GO TO FILL IN THE REST OF THIS  23100000
*                                  ROW IN E.                            23160000
INDX3    L     LWX,SVI                                                  23220000
         C     JK,4(LWX,MR)        SEE IF A IS AN INDEX.                23280000
         L     JK,M(JK)            JK IS A BASE FOR A NAMED ARRAY. 3561 23400000
         BC    7,INDX3C                                                 23460000
         TM    S,SON                                                    23520000
         BZ    INDX3C              BRANCH IF SUBSCRIPTED FETCH     3561 23580000
         B     NONCERR             ERROR IF SUBSCRIPED STORE       3561 23640000
INDX3A   DS    0H                                                       23700000
         LOOK  'I ELEMENT',M(I),M+63(I)                                 23760000
         LA    VCMPS1,0(JK,MR)     USING A LIST AS AN ELEMENT OF   3561 23820000
         TM    0(VCMPS1),MLSTBIT    AN INDEX LIST IS INVALID.      3561 23880000
         BO    SYNTERR                                             3561 23940000
INDX3C   EQU   *                                                   3561 24000000
         LH    JI,MRANK(JK)        FROM HERE TO INDX4 IS SETUP FOR THE  24060000
         LA    VCMPS1,1            INDX4 LOOP, WHICH GOES ALONG         24120000
         LTR   JI,JI               COLLECTING THE COMPONENTS OF THE     24180000
         BC    8,INDX6             RANK VECTOR OF THIS SUBSCRIPT ARRAY  24240000
         LR    R1,I                THE TWO STORES INTO E(WK) AND        24300000
         S     R1,IS               E+8(WK) ARE USED IN THE LOOP AT      24360000
         L     R2,WKS              INDX8, WHICH FILLS IN MORE OF E.     24420000
         ST    R1,E(R2)            THIS IS REALLY E(WK).                24480000
         ST    JI,E+8(R2)          AND THIS IS REALLY E+8(WK).          24540000
         AR    JI,JK               JI IS THE LOOP CONTROL FOR INDX4.    24600000
         LCR   R4,R4               I NEED A NEGATIVE FOUR TO USE BXH.   24660000
         L     R1,VKS              R1 HOLDS VK IN THIS LOOP.            24720000
         L     R0,SCRAM            SCRAMBLE.                            24780000
INDX4    L     VCMPS0,MRHO-4(JI)   CURRENT ELEMENT OF THE RANK VECTOR.  24840000
         LTR   R1,R1               CHECK FOR OVERFLOW OF F         3069 24900000
         BM    NONCERR             BRANCH IF TABLE OVERFLOW        3069 24960000
         LTR   VCMPS0,VCMPS0                                       3069 25020000
         BM    INDXERR             BRANCH IF NEGATIVE DIMENSION    3069 25080000
         ST    VCMPS0,F(R1)        OF THE CURRENT LIST ELEMENT.         25140000
         AR    R1,R4               SUBTRACT FOUR.                       25200000
         C     VCMPS0,ONE                                               25260000
         BC    8,INDX4BXH                                               25320000
         ALR   R0,R0               DO A NOT EQUAL REDUCTION.            25380000
         XR    R0,VCMPS0           XX                                   25440000
         MR    VCMPS0,VCMPS0       MULTIPLY VCMPS1 BY THE CURRENT       25500000
*                                  ELEMENT OF THE RANK VECTOR OF THE    25560000
*                                  CURRENT LIST ELEMENT ARRAY.          25620000
         BXLE  VCMPS0,VCMPS1,INDX4BXH  FALL THRU ON POS VCMPS0     3069 25680000
         L     VCMPS1,STRIKE       OVFLOW - SET TO CAUSE WS FULL   3069 25740000
INDX4BXH BXH   JI,R4,INDX4         JK IS THE COMPARAND FOR TERMINATION. 25800000
***********                        END OF THE INDX4 LOOP.  ***********  25860000
         ST    R0,SCRAM                                                 25920000
         ST    R1,VKS              NOW PUT VK BACK IN ITS HOME.         25980000
         LA    R4,4                GET BACK A PLUS FOUR IN R4.          26040000
         C     VCMPS1,ONE          HERE I CHECK FOR A SUBSCRIPT ARRAY   26100000
         BC    8,INDX6             HAVING ONLY ONE COMPONENT, AND IF IT 26160000
*                                  DOES I ADJUST SUM AND DO NOT PASS    26220000
*                                  THE CURRENT ROW OF E.                26280000
INDX5    L     WK,WKS              BUT, IF IT WAS NOT ONE, THEN I FILL  26340000
         ST    VCMPS1,E+12(WK)     IN SOME THINGS IN THIS ROW.          26400000
         ST    VCMPS1,E+16(WK)     XX                                   26460000
         L     R1,MRHO(A)          XX                                   26520000
         ST    R1,E+20(WK)         XX                                   26580000
         L     R1,ACMPS            XX                                   26640000
         ST    R1,E+4(WK)          XX                                   26700000
         S     WK,TWENTY8          GO TO THE PREVIOUS ROW IN E.         26760000
         ST    WK,WKS              XX                                   26820000
         M     VCMPS0,VCMPS        THIS IS COLLECTING X/RHO V.          26880000
         BXLE  VCMPS0,VCMPS1,*+8   FALL THRU ON POS VCMPS0         3069 26940000
         L     VCMPS1,STRIKE       OVFLOW - SET TO CAUSE WS FULL   3069 27000000
         ST    VCMPS1,VCMPS        XX                                   27060000
         BC    15,INDX7A           AND GO TO TEST FOR END OF BIG LOOP.  27120000
**********************************************************************  27180000
* IN THIS SECTION, I HAVE FOUND THAT THE CURRENT SUBSCRIPT ARRAY ONLY * 27240000
* HAS ONE ELEMENT. SO I AVOID USING A ROW IN E FOR THIS SUBSCRIPT     * 27300000
* POSITION BY TAKING THAT ELEMENT, SUBTRACTING THE INDEX ORIGIN FROM  * 27360000
* IT, AND MULTIPLYING BY THE WEIGHTING FACTOR FOR THE SUBSCRIPT       * 27420000
* POSITION. I THEN ADD THE RESULT TO SUM, WHICH WILL CONTAIN THE      * 27480000
* CURRENT VECTOR SUBSCRIPT OF THE LINEARIZED ARRAY A IN THE REAL      * 27540000
* INDEXING LOOP.                                                      * 27600000
**********************************************************************  27660000
INDX6FG  DC    AL1(INDX6B-INDX6A)  THESE OFFSETS ARE FOR BRANCHING      27720000
         DC    AL1(INDX6A-INDX6A)  ON THE TYPE OF THIS ONE-COMPONENT    27780000
         DC    AL1(INDX6C-INDX6A)  ARRAY.                               27840000
         DC    AL1(INDX6E-INDX6A)  XX                                   27900000
         DC    AL1(INDX6D-INDX6A)  XX                                   27960000
         CNOP  0,4                                                      28020000
INDX6    LR    R1,R4               THIS IS TO INSURE THAT THE LEFT 24   28080000
         IC    R1,MTYPE(JK)        BITS ARE ZERO.                       28140000
         AH    JK,MRANK(JK)        GO FOR THE ADDRESS OF ELEMENT 0.     28200000
         IC    R1,INDX6FG(R1)      GET THE REATIVE OFFSET FOR DECODING  28260000
         LA    R3,INDX6F           THE TYPE, AND THE CONTINUATION ADDR  28320000
         BC    15,INDX6A(R1)       DECODE.                              28380000
INDX6A   AR    JK,MR               THIS IS TYPE 1, BIT ARRAY.           28440000
         TM    12(JK),X'80'        IF IT IS A ZERO, LEAVE A ZERO IN R1  28500000
         BCR   8,R3                                                     28560000
         LA    R1,1                IF IT WAS A ONE, PUT A ONE IN R1.    28620000
         BCR   15,R3                                                    28680000
INDX6B   BC    15,TYPERR           THIS IS A TYPE ERROR, TYPE ZERO.     28740000
INDX6C   L     R1,MRHO(JK)         TYPE 2, INTEGER ARRAY.               28800000
         BCR   15,R3               EXIT.                                28860000
INDX6D   BC    15,TYPERR           THIS IS TYPE 4, A TYPE ERROR.        28920000
INDX6E   SR    R2,R2               TYPE 3, A FLOATING POINT ARRAY.      28980000
         LA    R4,MRHO-M(JK)       USE THE FETCH PROGRAM FOR THIS ONE.  29040000
         LA    R3,10               XX                                   29100000
         ICALL FETCH               XX                                   29160000
         LA    R4,4                PUT THAT 4 BACK.                     29220000
         LR    R1,R0               RESULT GOES IN R1, LIKE THE OTHERS.  29280000
INDX6F   EQU   *                   RESULT IS IN R1 NOW.                 29340000
         S     R1,IORIGIN          SUBTRACT THE INDEX ORIGIN.           29400000
         CL    R1,MRHO(A)          TEST TO SEE IF IT IS IN RANGE.       29460000
         BC    10,INDXERR          IF NOT, IT IS AN INDEXX ERROR.       29520000
         M     R0,ACMPS            ALL RIGHT, NOW MULTIPLY BY THE       29580000
         AR    SUM,R1              WEIGHTING FACTOR AND EKE SUM.        29640000
**********  TEST FOR THE END OF THE SETUP LOOP. *******                 29700000
INDX7    L     R1,ACMPS            GET THE WEIGHTING FACTOR FOR THE     29760000
INDX7A   M     R0,MRHO(A)          NEXT TIME AROUND THE LOOP, IF THERE  29820000
         ST    R1,ACMPS            IS ONE.                              29880000
         C     A,AS                OF RHO A, AND TEST FOR THE END OF    29940000
         BC    2,INDX2             THE HOUSEKEEPING LOOP.               30000000
         L     WK,WKS              GIVE WKLIM ITS VALUE.                30060000
         ST    WK,WKLIM            XX                                   30120000
         TM    S,SON                                                    30180000
         BC    7,RTEST                                                  30240000
         SR    R2,R2               FIGURE OUT EXACTLY HOW MUCH SPACE    30300000
         LR    R1,R2               IS NEEDED FOR V.                     30360000
         IC    R1,MTYPE(A)         THEN GET THAT AMOUNT OF SPACE.       30420000
         IC    R1,RIGHTBYT-1(R1)   XX                                   30480000
         M     R0,VCMPS            XX                                   30540000
         BXH   R0,R1,WSFULL        BRANCH IF R0 POSITIVE           3069 30600000
         A     R1,SEVEN            ROUND TO THE NEXT BYTE.         3069 30660000
         SRL   R1,3                XX                                   30720000
         CL    R1,STRIKE           CHECK FOR TOO-LARGE COUNT       3069 30780000
         BNL   WSFULL              XX                              3069 30840000
         LA    R1,12+FEND-F(R1)    ADD IN SPACE FOR THE RANK VECTOR.    30900000
         S     R1,VKS              XX                                   30960000
         ICALL GETSPACE            NOW GET THE SPACE                    31020000
         QUEND                                                          31080000
***** NOW FILL IN THE TYPE, RHO RHO V, AND RHO V OF THE NEW V. ******** 31140000
INDX8    L     LWX,SVI                                                  31200000
* PERMUTE THE STACK TO OBTAIN                                           31260000
* V AT SVI+12 INSTEAD OF I,                                             31320000
* I AT SVI+8  INSTEAD OF A,                                             31380000
* A AT SVI+4  INSTEAD OF V.                                             31440000
         LA    R4,0(LWX,MR)        GET AN ABSOLUTE ADDRESS.             31500000
         LM    R1,R3,4(R4)         LOAD V,A, AND I IN R1,R2, AND R3.    31560000
         ST    R1,12(R4)           STORE V IN ITS NEW PLACE.            31620000
         STM   R2,R3,4(R4)         STORE A AND I IN THEIR PLACES.       31680000
         L     R0,M(R3)            XX                                   31800000
         S     R0,FOUR             XX                                   31860000
         ST    R0,M(R3)            XX                                   31920000
         L     R0,M(R1)            XX                                   32040000
         A     R0,EIGHT            XX                                   32100000
         ST    R0,M(R1)            XX                                   32160000
         LTR   R2,R2               CHANGE THE A STACK POINTER ONLY IF   32220000
         BC    4,INDX8A            IT IS AN UNNAMED ARRAY.              32280000
         L     R0,M(R2)            XX                                   32400000
         S     R0,FOUR             XX                                   32460000
         ST    R0,M(R2)                                                 32520000
INDX8A   EQU   *                                                        32580000
         BAL   R1,BASES            BASE I, A, AND V.                    32640000
         LA    R0,1                GET A ONE IN R0.                     32700000
         LR    R1,R0               MAKE SURE THE LEFT 24 BITS ARE ZERO. 32760000
         IC    R1,MTYPE(A)                                              32820000
         ALR   R1,R1               GET THE ENTRY FOR THE DOWN SECTION.  32880000
         LH    R2,DOWNBTAB-2(R1)   XX                                   32940000
         AR    R2,12               XX                                   33000000
         ST    R2,DOWNADR          XX                                   33060000
         SLL   R1,23               LEFT JUSTIFY THE TYPE.               33120000
         LA    R3,FEND-F                                                33180000
         S     R3,VKS              R3 NOW HAS 4 X RHO RHO V.            33240000
         AR    R1,R3                                                    33300000
         ST    R1,MTYPE(V)                                              33360000
         SR    R3,R0               SUBTRACT A ONE.                      33420000
         BC    4,INDX8B                                                 33480000
         LA    R1,12(V,MR)                                              33540000
         L     R4,VKS                                                   33600000
         LA    R4,4+F(R4)                                               33660000
         EX    R3,INDX8MVC                                              33720000
INDX8B   EQU   *                                                        33780000
         LA    V,13(V,R3)                                               33840000
COMMON   EQU   *                                                        33900000
         LOOK  'COMMON, DSECT.',FUG1,FUG2                               33960000
         LA    DOWNY,INDXFIN       THIS IS IN CASE OF EMPTY OR SCALARS. 34020000
         L     R0,VCMPS            IF THE SUBSCRIPT FOR A IS AN EMPTY   34080000
         LTR   R0,R0               ARRAY, FINISH QUICK.                 34140000
         BCR   8,DOWNY             XX                                   34200000
         LA    WK,WK1              SEE IF THE MATRIX E HAS              34260000
         C     WK,WKLIM            ANYTHING IN IT.                      34320000
         BC    7,INDX7K            GO IF IT DOES.                       34380000
         AH    A,MRANK(A)                                               34440000
         LA    A,12(A)                                                  34500000
         LA    R5,8                                                     34560000
         ST    DOWNY,DOWNYSV                                            34620000
         L     LOOPRG,DOWNADR                                           34680000
         LA    ONEREG,1                                                 34740000
         BCR   15,LOOPRG                                                34800000
INDX7K   L     R2,E+8(WK)                                               34860000
         LTR   R2,R2                                                    34920000
         BC    8,INDX7L                                                 34980000
         L     R3,E(WK)            GET THE ADDRESS OF THE SUBSCRIPT.    35040000
         AR    R3,I                                                     35100000
         L     R3,MRHO(R3)                                              35160000
         BMW   R3                                                       35220000
         SR    R4,R4                                                    35280000
         IC    R4,MTYPE(R3)                                             35340000
         AR    R4,R4                                                    35400000
         LH    R4,FTCHBTAB-2(R4)                                        35460000
         AR    R4,12               MAKE IT AN ABSOLUTE ADDRESS.         35520000
         ST    R4,E+24(WK)                                              35580000
         LA    R3,12(R3,R2)        GET ADDRESS OF ELEMENT ZERO.         35640000
         ST    R3,E+8(WK)                                               35700000
         SR    R0,R0                                                    35760000
         ST    R0,E(WK)                                                 35820000
         BC    15,INDX7M                                                35880000
INDX7L   LA    R1,NOW1                                                  35940000
         ST    R1,E+24(WK)                                              36000000
INDX7M   S     WK,TWENTY8                                               36060000
         C     WK,WKLIM                                                 36120000
         BC    2,INDX7K                                                 36180000
         AH    A,MRANK(A)                                               36240000
         LA    A,12(A)                                                  36300000
         LA    R5,8                                                     36360000
         MVI   SWICH,X'00'                                              36420000
         LA    WK,WK1                                                   36480000
         L     LOOPRG,DOWNADR                                           36540000
         LA    ONEREG,1                                                 36600000
         LA    DOWNY,BEGIN                                              36660000
         ST    DOWNY,DOWNYSV                                            36720000
         BC    15,BEGIN                                                 36780000
INDX8MVC MVC   0(1,R1),0(R4)                                            36840000
RTEST    L     LWX,SVI                                                  36900000
         BASE  V,12                                                     36960000
         LA    R4,4                                                     37020000
         LH    JI,MRANK(V)                                              37080000
         AR    JI,V                                                     37140000
         LA    R3,1                                                     37200000
         LR    R1,R3                                                    37260000
         SR    R2,R2                                                    37320000
         CR    JI,V                                                     37380000
         BC    8,RTEST3                                                 37440000
RTEST1   L     R0,MRHO-4(JI)                                            37500000
         CR    R0,R3                                                    37560000
         BC    8,RTEST2                                                 37620000
         ALR   R2,R2                                                    37680000
         XR    R2,R0                                                    37740000
         MR    R0,R0                                                    37800000
         BXLE  R0,R1,RTEST2        FALL THRU IF R0 POS             3069 37860000
         L     R1,STRIKE           OVFLOW - SET R1 TO CAUSE WSFULL 3069 37920000
RTEST2   SR    JI,R4                                                    37980000
         CR    JI,V                                                     38040000
         BC    2,RTEST1                                                 38100000
         CL    R1,STRIKE           CHECK FOR X/RHO V TOO LARGE     3069 38160000
         BNL   WSFULL              BRANCH IF TOO LARGE             3069 38220000
RTEST3   ST    R1,VCMPS2                                                38280000
         CR    R1,R3                                                    38340000
         BC    8,RTEST4                                                 38400000
         C     R1,VCMPS                                                 38460000
         BC    7,LNGERR                                                 38520000
         C     R2,SCRAM                                                 38580000
         BC    7,RNKERR                                                 38640000
RTEST4   EQU   *                                                        38700000
         LA    R1,0(V,MR)                                               38760000
         TM    8(R1),X'02'                                              38820000
         BC    8,OKAY                                                   38880000
         LA    R2,0(A,MR)                                               38940000
         CLI   8(R2),X'02'                                              39000000
         BC    2,OKAY                                                   39060000
        BC    7,CHK13                                                   39120000
RTEST5   CLI   8(R1),X'03'                                              39180000
         BC    8,CHK23                                                  39240000
OKAY     EQU   *                                                        39300000
         QUEND                                                          39360000
         SR    R1,R1                                                    39420000
         IC    R1,MTYPE(A)                                              39480000
         LR    R2,R1                                                    39540000
         IC    R2,MTYPE(V)                                              39600000
         AH    V,MRANK(V)                                               39660000
         LA    V,12(V)                                                  39720000
         SLL   R1,2                                                     39780000
         L     R3,VCMPS2                                                39840000
         C     R3,ONE                                                   39900000
         BC    7,OKAY2                                                  39960000
* FETCH THE SINGLE ELEMENT OF V AND STASH IT AWAY FOR LATER. *          40020000
         L     R0,OKAY1-4(R1)                                           40080000
         ST    R0,DOWNADR                                               40140000
         AR    R1,R2                                                    40200000
         IC    R3,DIDLTYP-5(R1)                                         40260000
         LTR   R3,R3                                                    40320000
         BC    8,TYPERR                                                 40380000
         LR    R4,V                                                     40440000
         SR    R2,R2                                                    40500000
         ICALL FETCH                                                    40560000
         STM   R0,R1,VALUE                                              40620000
         BC    15,COMMON                                                40680000
         CNOP  0,4                                                      40740000
OKAY1    DC    AL4(DOWNS51)                                             40800000
         DC    AL4(DOWNS52)                                             40860000
         DC    AL4(DOWNS53)                                             40920000
         DC    AL4(DOWNS54)                                             40980000
OKAY2    EQU   *                                                        41040000
         AR    R1,R2                                                    41100000
         AR    R1,R1                                                    41160000
         LH    R1,DOWNBTAB-2(R1)                                        41220000
         AR    R1,12                                                    41280000
         ST    R1,DOWNADR                                               41340000
         BC    15,COMMON                                                41400000
CHK12    EQU   *                                                        41460000
         LH    R1,MRANK(V)                                              41520000
         LA    R2,4                                                     41580000
         SR    R1,R2                                                    41640000
         AR    R1,V                                                     41700000
         LA    R1,12(R1,MR)                                             41760000
         L     R3,VCMPS2                                                41820000
         SLL   R3,2                                                     41880000
         AR    R3,R1                                                    41940000
         LA    R0,1                                                     42000000
         LA    R5,CHK12C                                                42060000
         BC    15,CHK12B                                                42120000
CHK12A   CL    R0,0(R1)                                                 42180000
         BCR   4,R5                                                     42240000
CHK12B   BXLE  R1,R2,CHK12A                                             42300000
         BC    15,CHKFIN                                                42360000
CHK13   TM    8(R1),X'01'                                               42420000
        BC    8,CHK12                                                   42480000
         LA    R3,11               TRY TO MAKE IT TYPE 1 WITHOUT FUZZ   42540000
         ON    RNG,CHK13C                                               42600000
CHK13X   LH    R4,MRANK(V)                                              42660000
         LA    R4,12(R4,V)                                              42720000
         L     R2,VCMPS2           LOAD THE NUMBER OF COMPONENTS IN V.  42780000
         LTR   R2,R2                                                    42840000
         BC    8,CHKFIN                                                 42900000
         LA    R5,1                                                     42960000
         LCR   R5,R5                                                    43020000
         BC    15,CHK13B                                                43080000
CHK13A   EQU   *                                                        43140000
         ICALL FETCH                                                    43200000
         QUEND                                                          43260000
CHK13B   BXH   R2,R5,CHK13A                                             43320000
         ON    RNG                                                      43380000
         BC    15,CHKFIN                                                43440000
CHK13C   LA    R3,12               TRY TO MAKE IT TYPE 2 WITHOUT FUZZ   43500000
         ON    RNG,CHK13E                                               43560000
CHK13D   ICALL FETCH                                                    43620000
         BXH   R2,R5,CHK13D                                             43680000
         ON    RNG                                                      43740000
CHK12C   LA    R6,COPY21           IT IS OKAY AS A TYPE 2, CONVERT IT.  43800000
         LA    R2,2                                                     43860000
         BC    15,COPY                                                  43920000
CHK13E   LA    R6,COPY31           HAVE TO COPY IT OVER TO TYPE 3.      43980000
         LA    R2,3                                                     44040000
         ON    RNG                                                      44100000
         BC    15,COPY                                                  44160000
CHK23    LA    R3,12                                                    44220000
         ON    RNG,CHK23C                                               44280000
         BC    15,CHK13X                                                44340000
CHK23C   LA    R2,3                I HAVE TO CONVERT IT TO Y TYPE 3.    44400000
         LA    R6,COPY32                                                44460000
         ON    RNG                                                      44520000
*********************************************************************** 44580000
* ROUTINE TO COPY A OVER TO A NEW ARRAY, POSSIBLY CHANGING THE TYPE   * 44640000
* AS THE COPYING TAKES PLACE. THE ONLY CASE WHERE THE TYPE IS NOT     * 44700000
* CHANGED IN A COPY IS WHEN A(I) GETS A, OR A(A) GETS X.              * 44760000
* REGISTER 6 CONTAINS THE ADDRESS OF THE APPROPRIATE CONVERSION SECTION 44820000
* TO BE PERFORMED DURING THE COPY, AND R2 CONTAINS THE TYPE OF THE NEW* 44880000
* ARRAY. AFTER COPY IS DONE IT GOES TO CHKFIN, TO FILL IN DOWNADR.    * 44940000
*********************************************************************** 45000000
COPY     LR    R1,R2                                                    45060000
         IC    R1,RIGHTBYT-1(R2)   FIGURE OUT EXACTLY HOW MUCH SPACE    45120000
         M     R0,ACMPS            THE NEW ARRAY WILL TAKE UP.          45180000
         LA    R1,7(R1)            ROUND UP TO EVEN BYTE.               45240000
         SRL   R1,3                XX                                   45300000
         LH    R3,MRANK(A)                                              45360000
         LA    R1,12(R1,R3)                                             45420000
         ICALL GETSPACE                                                 45480000
         L     LWX,SVI             NO STACK POINTER FROM THE GETSPACE.  45540000
         L     R5,4(LWX,MR)        GET SYMBOL TABLE ADDRESS.            45600000
         L     A,0(R5,MR)          GET THE ADDRESS OF THE OLD M-ENTRY.  45720000
         A     R1,FIVECON                                               45840000
         ST    R1,0(R5,MR)         FIX THE SYMBOL TABLE TO POINT TO THE 45900000
         L     R0,0(A,MR)          NEW ARRAY.                           46020000
         ST    R0,0(R1,MR)         MAKE NEW EMTRY POINT ON SYMBOL TABLE 46080000
         LR    R0,R2                                                    46140000
         SLL   R0,24               GET THE TYPE LEFT JUSTIFIED.         46200000
         AR    R0,R3               AND PLACE THE NUMBER OF DIMENSIONS.  46260000
         ST    R0,8(R1,MR)         FILL IN TYPE AND RHO RHO.            46320000
         LA    R4,12(A,MR)         SOURCE IS R4.                        46380000
         LA    V,12(R1,R3)                                              46440000
         LA    R1,12(R1,MR)                                             46500000
         BCTR  R3,0                                                     46560000
         EX    R3,INDX8MVC                                              46620000
         LR    R1,A                                                     46680000
         LWUG                                                           46740000
         LA    A,13(A,R3)          A IS NOW READY FOR COPYING.          46800000
         L     R5,ACMPS                                                 46860000
         BCR   15,R6               BRANCH TO THE RIGHT PLACE.           46920000
COPY21   SLL   R5,2                                                     46980000
         LA    R4,4                                                     47040000
         SR    V,R4                                                     47100000
         AR    R5,V                                                     47160000
         LA    R3,32                                                    47220000
         SR    R2,R2                                                    47280000
         L     R1,0(A,MR)                                               47340000
COPY21A  BXH   V,R4,COPYFIN        COPY FROM A TO V.                    47400000
COPY21B  LR    R0,R2                                                    47460000
         SLDL  R0,1                                                     47520000
         ST    R0,0(V,MR)                                               47580000
         BCT   R3,COPY21A                                               47640000
         LA    R3,32                                                    47700000
         AR    A,R4                                                     47760000
         L     R1,0(A,MR)                                               47820000
         BXLE  V,R4,COPY21B                                             47880000
         BC    15,COPYFIN                                               47940000
*   REGISTER USAGES. *                                                  48000000
* R0 -- TRANSIT REGISTER.                                               48060000
* R1 -- TEMPORARY HOLDER FOR BITS FROM A.                               48120000
* R2 -- A CONSTANT ZERO.                                                48180000
* R3 -- COUNT DOWN FROM 32, TO TELL WHEN R1 IS USED UP.                 48240000
* R4 -- A CONSTANT FOUR FOR THE BXH.                                    48300000
* R5 -- LIMIT FOR V, (INITIAL V BASE =BASE+12+MRANK)+4 X NEG 1 PLUS RHO 48360000
* A INITIALLY, ADDRESS OF ELEMENT ZERO OF OLD ARRAY.                    48420000
* V  -- INITIALLY, ELEMENT ZERO OF NEW ARRAY.                           48480000
COPY31   SLL   R5,3                                                     48540000
         LA    R4,8                                                     48600000
         SR    V,R4                                                     48660000
         AR    R5,V                                                     48720000
         LA    R3,32                                                    48780000
         LA    R2,X'208'                                                48840000
         SR    R6,R6                                                    48900000
         L     R1,0(A,MR)          LOAD UP THE FIRST 32 BITS.           48960000
COPY31A  BXH   V,R4,COPYFIN                                             49020000
COPY31B  ST    R6,4(V,MR)                                               49080000
         SR    0,0                                                      49140000
         ALR   1,1                                                      49200000
         BC    12,*+8              BRANCH NO CARRY                      49260000
         L     0,FLOAT1                                                 49320000
         ST    R0,0(V,MR)                                               49380000
         BCT   R3,COPY31A                                               49440000
         LA    R3,32               REFILL COUNTER.                      49500000
         LA    A,4(A)                                                   49560000
         L     R1,0(A,MR)                                               49620000
         BXLE  V,R4,COPY31B                                             49680000
         BC    15,COPYFIN                                               49740000
COPY32   SLL   R5,3                                                     49800000
         LA    R4,8                                                     49860000
         SR    V,R4                                                     49920000
         AR    R5,V                                                     49980000
COPY32A  BXH   V,R4,COPYFIN                                             50040000
COPY32B  L     R1,0(A,MR)                                               50100000
         LA    R0,X'48'                                                 50160000
         LTR   R1,R1               SHOULD I COMPLEMENT THE NUMBER.      50220000
         BC    10,COPY32C                                               50280000
         LCR   R1,R1                                                    50340000
         BC    1,COPY32E                                                50400000
         LA    R0,X'C8'                                                 50460000
COPY32C  SLDL  R0,24                                                    50520000
         STM   R0,R1,VALUE                                              50580000
         SDR   0,0                                                      50640000
         AD    0,VALUE                                                  50700000
         STD   0,VALUE                                                  50760000
         LA    R1,0(V,MR)                                               50820000
         MVC   0(8,R1),VALUE                                            50880000
         LA    A,4(A)                                                   50940000
         BXLE  V,R4,COPY32B                                             51000000
         BC    15,COPYFIN                                               51060000
COPY32E  LA    R1,0(V,MR)                                               51120000
         MVC   0(8,R1),NEGNUM                                           51180000
         LA    A,4(A)                                                   51240000
         BC    15,COPY32A                                               51300000
CHKFIN   EQU   *                                                        51360000
COPYFIN  LA    R1,OKAY                                                  51420000
         BC    15,BASES                                                 51480000
*************** EVALUATION, DOWN. ***********                           51540000
DOWNBTAB DC    AL2(DOWNBIT-ORGY)   HEAP BIG BRANCH TABLE.               51600000
         DC    AL2(DOWNINT-ORGY)                                        51660000
         DC    AL2(DOWNFLP-ORGY)                                        51720000
         DC    AL2(DOWNCHAR-ORGY)                                       51780000
         DC    AL2(DOWNS11-ORGY)                                        51840000
         DC    AL2(DOWNS12-ORGY)                                        51900000
         DC    AL2(DOWNS13-ORGY)                                        51960000
         DC    AL2(TYPERR-ORGY)                                         52020000
         DC    AL2(DOWNS21-ORGY)                                        52080000
         DC    AL2(DOWNS22-ORGY)                                        52140000
         DC    AL2(DOWNS23-ORGY)                                        52200000
         DC    AL2(TYPERR-ORGY)                                         52260000
         DC    AL2(DOWNS31-ORGY)                                        52320000
         DC    AL2(DOWNS32-ORGY)                                        52380000
         DC    AL2(DOWNS33-ORGY)                                        52440000
         DC    AL2(TYPERR-ORGY)                                         52500000
         DC    AL2(TYPERR-ORGY)                                         52560000
         DC    AL2(TYPERR-ORGY)                                         52620000
         DC    AL2(TYPERR-ORGY)                                         52680000
         DC    AL2(DOWNS44-ORGY)                                        52740000
DOWNS11  EQU   *                                                        52800000
         LR    R2,SUM                                                   52860000
         SRDL  R2,3                                                     52920000
         SRL   R3,29                                                    52980000
         AR    R2,A                                                     53040000
         AR    R2,MR                                                    53100000
         SR    R5,ONEREG                                                53160000
         IC    R1,M(V)                                                  53220000
         SRL   R1,0(R5)                                                 53280000
         NR    R1,ONEREG                                                53340000
         BC    7,DOWNS11A                                               53400000
         IC    R3,BITBIT0(R3)                                           53460000
         EX    R3,ANDIMED                                               53520000
         LTR   R5,R5                                                    53580000
         BCR   7,DOWNY                                                  53640000
         LA    V,1(V)                                                   53700000
         LA    R5,8                                                     53760000
         BCR   15,DOWNY                                                 53820000
DOWNS11A IC    R3,BITBIT1(R3)                                           53880000
         EX    R3,ORIMED                                                53940000
         LTR   R5,R5                                                    54000000
         BCR   7,DOWNY                                                  54060000
         LA    V,1(V)                                                   54120000
         LA    R5,8                                                     54180000
         BCR   15,DOWNY                                                 54240000
DOWNS12  EQU   *                                                        54300000
         LR    R2,SUM                                                   54360000
         SRDL  R2,3                                                     54420000
         SRL   R3,29                                                    54480000
         AR    R2,A                                                     54540000
         AR    R2,MR                                                    54600000
         L     R1,0(MR,V)                                               54660000
         LA    V,4(V)                                                   54720000
         BXLE  R1,R1,DOWNS12A                                           54780000
DOWNS51A EQU   *                                                        54840000
         IC    R3,BITBIT1(R3)                                           54900000
         EX    R3,ORIMED                                                54960000
         BCR   15,DOWNY                                                 55020000
DOWNS13  LA    R5,0                                                     55080000
         LA    R0,DOWNS13A                                              55140000
         ST    R0,DOWNADR                                               55200000
DOWNS13A LR    R2,R5                                                    55260000
         LR    R4,V                                                     55320000
         LA    R3,9                                                     55380000
         ICALL FETCH                                                    55440000
         L     DOWNY,DOWNYSV                                            55500000
         LA    LOOPRG,DOWNS13A                                          55560000
         AR    R5,ONEREG                                                55620000
         LR    R2,SUM                                                   55680000
         SRDL  R2,3                                                     55740000
         SRL   R3,29                                                    55800000
         AR    R2,A                                                     55860000
         AR    R2,MR                                                    55920000
         LTR   R0,R0                                                    55980000
         BC    7,DOWNS13B                                               56040000
DOWNS12A EQU   *                                                        56100000
         IC    R3,BITBIT0(R3)                                           56160000
         EX    R3,ANDIMED                                               56220000
         BCR   15,DOWNY                                                 56280000
DOWNS13B IC    R3,BITBIT1(R3)                                           56340000
         EX    R3,ORIMED                                                56400000
         BCR   15,DOWNY                                                 56460000
DOWNS21  LA    R2,0(SUM,SUM)                                            56520000
         AR    R2,R2                                                    56580000
         AR    R2,A                                                     56640000
         SR    R5,ONEREG                                                56700000
         IC    R1,M(V)                                                  56760000
         SRL   R1,0(R5)                                                 56820000
         BC    7,DOWNS21A                                               56880000
         LA    R5,8                                                     56940000
         AR    V,ONEREG                                                 57000000
DOWNS21A NR    R1,ONEREG                                                57060000
         ST    R1,M(R2)                                                 57120000
         BCR   15,DOWNY                                                 57180000
DOWNS22  EQU   *                                                        57240000
         LA    R1,0(SUM,SUM)                                            57300000
         AR    R1,R1                                                    57360000
         AR    R1,A                                                     57420000
         L     R0,M(V)                                                  57480000
         ST    R0,M(R1)                                                 57540000
         LA    V,4(V)                                                   57600000
         BCR   15,DOWNY                                                 57660000
DOWNS23  LA    R5,0                                                     57720000
         LA    R0,DOWNS23A                                              57780000
         ST    R0,DOWNADR                                               57840000
DOWNS23A LR    R2,R5                                                    57900000
         LA    R3,10                                                    57960000
         LR    R4,V                                                     58020000
         ICALL FETCH                                                    58080000
         LA    R2,0(SUM,SUM)                                            58140000
         AR    R2,R2                                                    58200000
         AR    R2,A                                                     58260000
         ST    R0,M(R2)                                                 58320000
         AR    R5,ONEREG                                                58380000
         LA    LOOPRG,DOWNS23A                                          58440000
         L     DOWNY,DOWNYSV                                            58500000
         BCR   15,DOWNY                                                 58560000
DOWNS31  LR    R2,SUM                                                   58620000
         SLL   R2,3                                                     58680000
         AR    R2,A                                                     58740000
         SR    R5,ONEREG                                                58800000
         IC    R1,M(V)                                                  58860000
         SRL   R1,0(R5)                                                 58920000
         NR    R1,ONEREG                                                58980000
         BZ    *+8                                                      59040000
         LA    R1,X'410'(R1)                                            59100000
         SLDL  R0,52                                                    59160000
         AR    R2,MR                                                    59220000
         STM   R0,R1,0(R2)                                              59280000
         LTR   R5,R5                                                    59340000
         BCR   7,DOWNY             A                                    59400000
         LA    R5,8                                                     59460000
         AR    V,ONEREG                                                 59520000
         BCR   15,DOWNY                                                 59580000
DOWNS32  LR    R2,SUM                                                   59640000
         SLL   R2,3                                                     59700000
         AR    R2,A                                                     59760000
         AR    R2,MR                                                    59820000
         L     R1,M(V)                                                  59880000
         LA    R0,X'48'                                                 59940000
         LTR   R1,R1               IS THE NUMBER NEGATIVE?              60000000
         BC    10,DOWNS32A                                              60060000
         LCR   R1,R1               IF IT WAS NEGATIVE, COMPLEMENT IT.   60120000
         BC    1,DOWNS32B          TGEST FOR MINUS 2*32.                60180000
         LA    R0,X'C8'            AND SET THE SIGN TO MINUS.           60240000
DOWNS32A SLDL  R0,24                                                    60300000
         STM   R0,R1,VALUE                                              60360000
         SDR   0,0                                                      60420000
         AD    0,VALUE                                                  60480000
         STD   0,VALUE                                                  60540000
         MVC   0(8,R2),VALUE                                            60600000
         LA    V,4(V)                                                   60660000
         BCR   15,DOWNY                                                 60720000
DOWNS32B MVC   0(8,R2),NEGNUM      MINUS 2*32.                          60780000
         LA    V,4(V)              EKE V PLUS FOUR.                     60840000
         BCR   15,DOWNY                                                 60900000
DOWNS33  LR    R2,SUM                                                   60960000
         SLL   R2,3                                                     61020000
         AR    R2,A                                                     61080000
         LA    R1,0(MR,V)                                               61140000
         AR    R2,MR                                                    61200000
         MVC   0(8,R2),0(R1)                                            61260000
         AR    V,R5                                                     61320000
         BCR   15,DOWNY                                                 61380000
DOWNS44  EQU   *                                                        61440000
         LA    R1,0(SUM,A)                                              61500000
         IC    R0,M(V)                                                  61560000
         STC   R0,M(R1)                                                 61620000
         AR    V,ONEREG                                                 61680000
         BCR   15,DOWNY                                                 61740000
DOWNS51  LR    R2,SUM                                                   61800000
         SRDL  R2,3                                                     61860000
         SRL   R3,29                                                    61920000
         AR    R2,A                                                     61980000
         AR    R2,MR                                                    62040000
         TM    VALUE,X'80'                                              62100000
         BC    7,DOWNS51A                                               62160000
         IC    R3,BITBIT0(R3)                                           62220000
         EX    R3,ANDIMED                                               62280000
         BCR   15,DOWNY                                                 62340000
DOWNS52  LA    R2,0(SUM,SUM)                                            62400000
         AR    R2,R2                                                    62460000
         AR    R2,A                                                     62520000
         L     R0,VALUE                                                 62580000
         ST    R0,M(R2)                                                 62640000
         BCR   15,DOWNY                                                 62700000
DOWNS53  LR    R2,SUM                                                   62760000
         SLL   R2,3                                                     62820000
         AR    R2,A                                                     62880000
         AR    R2,MR                                                    62940000
         LM    R0,R1,VALUE                                              63000000
         STM   R0,R1,0(R2)                                              63060000
         BCR   15,DOWNY                                                 63120000
DOWNS54  LA    R1,0(SUM,A)                                              63180000
         IC    R0,VALUE                                                 63240000
         STC   R0,M(R1)                                                 63300000
         BCR   15,DOWNY                                                 63360000
DOWNBIT  LR    R1,SUM              TYPE 1, BIT ARRAY.                   63420000
         LR    R2,SUM              XX                                   63480000
         N     R1,SEVEN                                                 63540000
         SRL   R2,3                                                     63600000
         AR    R2,MR                                                    63660000
         IC    R0,0(R2,A)                                               63720000
         IC    R1,BITBIT1(R1)                                           63780000
         NR    R0,R1                                                    63840000
         LA    R2,0(V,MR)                                               63900000
         BC    8,DOWNBIT1                                               63960000
         IC    R3,BITBIT3-1(R5)                                         64020000
         EX    R3,ORIMED                                                64080000
         BCTR  R5,DOWNY                                                 64140000
         LA    R5,8                                                     64200000
         LA    V,1(V)                                                   64260000
         BCR   15,DOWNY                                                 64320000
DOWNBIT1 IC    R3,BITBIT4-1(R5)                                         64380000
         EX    R3,ANDIMED                                               64440000
         BCTR  R5,DOWNY                                                 64500000
         LA    R5,8                                                     64560000
         LA    V,1(V)                                                   64620000
         BCR   15,DOWNY                                                 64680000
BITBIT0  DC    XL8'7FBFDFEFF7FBFDFE'                                    64740000
BITBIT1  DC    XL8'8040201008040201'                                    64800000
BITBIT3  DC    XL8'0102040810204080'                                    64860000
BITBIT4  DC    XL8'FEFDFBF7EFDFBF7F'                                    64920000
ORIMED   OI    0(R2),X'00'                                              64980000
ANDIMED  NI    0(R2),X'00'                                              65040000
DOWNINT  LA    R1,0(SUM,SUM)                                            65100000
         AR    R1,R1                                                    65160000
         AR    R1,MR                                                    65220000
         L     R1,0(R1,A)                                               65280000
         ST    R1,0(V,MR)                                               65340000
         LA    V,4(V)                                                   65400000
         BCR   15,DOWNY                                                 65460000
DOWNFLP  LR    R1,SUM                                                   65520000
         SLL   R1,3                                                     65580000
         AR    R1,MR                                                    65640000
         AR    R1,A                                                     65700000
         LA    R2,0(V,MR)                                               65760000
         MVC   0(8,R2),0(R1)                                            65820000
         AR    V,R5                                                     65880000
         BCR   15,DOWNY                                                 65940000
DOWNCHAR LA    R1,0(SUM,MR)                                             66000000
         IC    R0,0(R1,A)                                               66060000
         STC   R0,0(V,MR)                                               66120000
         AR    V,ONEREG                                                 66180000
         BCR   15,DOWNY                                                 66240000
DOWNY    EQU   R4                  USUALLY CONTAINS ADDRESS OF BEGIN.   66300000
* EI3 IS R1, SUM IS R7,WK IS R6,THERE IS AN 8 IN R5 EXCEPT DURING BIT   66360000
* INDEXING, A IS IN R9, V IS IN R10, AND THERE IS A 1 IN R8. LOOPRG IS  66420000
* REGISTER FIFTEEN.                                                     66480000
BEGIN    LA    WK,WK1                                                   66540000
         QUEND                                                          66600000
MORE     S     SUM,E(WK)                                                66660000
         LOOK  'MORE',FUG1,FUG2                                         66720000
         L     EI3,E+12(WK)                                             66780000
         AR    EI3,ONEREG                                               66840000
         CL    EI3,E+16(WK)                                             66900000
         BC    4,HERE                                                   66960000
         SR    EI3,EI3                                                  67020000
         LA    LOOPRG,WKDEC                                             67080000
HERE     ST    EI3,E+12(WK)                                             67140000
         L     R3,E+24(WK)                                              67200000
         BALR  R3,R3                                                    67260000
NOW      S     R1,IORIGIN                                               67320000
         CL    R1,E+20(WK)                                              67380000
         BC    10,INDXERR                                               67440000
NOW1     M     R0,E+4(WK)                                               67500000
         ST    R1,E(WK)                                                 67560000
         AR    SUM,R1                                                   67620000
         BCR   15,LOOPRG                                                67680000
* SECTION TO OBTAIN ELEMENTS OF SUBSCRIPT ARRAYS.                    *  67740000
* R1 CONTAINS THE INDEX OF THE ELEMENT DESIRED, /-ORIGIN, AND THE    *  67800000
* RESULT IS PLACED IN REGISTER 1 AS A FIXED POINT INTEGER.           *  67860000
* AT E+8(WK) IS THE M-RELATIVE ADDRESS OF ELEMENT ZERO OF THE        *  67920000
* SUBSCRIPT ARRAY. R3 CONTAINS THE ADDRESS TO BRANCH TO AFTERWARDS.  *  67980000
FTCHBIT  LR    R2,R1               HERE I GET AN ELEMENT OUT OF A BIT   68040000
         N     R2,SEVEN            ARRAY.                               68100000
         SRL   R1,3                R1 NOW HAS A RELATIVE BYTE ADDRESS.  68160000
         A     R1,E+8(WK)          ADD IN THE ADDRESS OF ELEMENT ZERO.  68220000
         IC    R0,M(R1)            OBTAIN THE BYTE CONTAINING THE BIT.  68280000
         LR    R1,ONEREG           GET SET FOR A ONE, THEN SEE IF IT IS 68340000
         IC    R2,BITBIT1(R2)      REALLY A ONE.                        68400000
         NR    R0,R2               IF THE RESULT OF THIS AND IS A ONE,  68460000
         BCR   7,R3                THEN THE DESIRED BIT IS A ONE.       68520000
         SR    R1,R1               HOWEVER, HERE I FIND IT IS NOT A ONE 68580000
         BCR   15,R3               SO I SET R1 TO ZERO AND EXIT.        68640000
FTCHINT  SLL   R1,2                FETCH AN ELEMENT OUT OF AN INTEGER   68700000
         A     R1,E+8(WK)          ARRAY.                               68760000
         L     R1,M(R1)            THIS ONE IS EASY, JUST GET IT.       68820000
         BCR   15,R3               THEN LEAVE.                          68880000
FTCHFLP  ST    R3,SAVEM1           THIS ONE IS HARDER, FETCHING AN      68940000
         L     R4,E+8(WK)          ELEMENT OUT OF A FLOATING POINT      69000000
         LR    R2,R1               ARRAY AND CONVERTING IT FIXED.       69060000
         LA    R3,10               FOR THIS I USE THE FETCH PROGRAM.    69120000
         ST    LOOPRG,FUDGE        LOOPRG IS 15, SO I HAVE TO SAVE IT.  69180000
         ICALL FETCH                                                    69240000
         L     LOOPRG,FUDGE        NOW RESTORE REGISTERS 15 AND 3 TO    69300000
         L     R3,SAVEM1           WHAT THEY WERE INITIALLY.            69360000
         LR    R1,R0               LEAVE THE ELEMENT IN R1 INSTEAD OF 0 69420000
         LA    DOWNY,BEGIN         DOWNY IS R4, SO I HAVE TO RESTORE IT 69480000
         BCR   15,R3               THEN JUST LEAVE.                     69540000
FTCHBTAB DC    AL2(FTCHBIT-ORGY)   TYPE 1, BITS.                        69600000
         DC    AL2(FTCHINT-ORGY)   TYPE 2, INTEGER.                     69660000
         DC    AL2(FTCHFLP-ORGY)   TYPE 3, FLOATING POINT.              69720000
         DC    AL2(INDXERR-ORGY)   TYPE 4, A MISTAKE.                   69780000
WKDEC    S     WK,TWENTY8                                               69840000
         C     WK,WKLIM                                                 69900000
         L     LOOPRG,DOWNADR                                           69960000
         BC    2,MORE              KEEP GOING AS LONG AS WK IS BIGGER.  70020000
         XI    SWICH,X'FF'                                              70080000
         BCR   7,LOOPRG            GO USE THE FIRST ONE.                70140000
**********************************************************************  70200000
*  THIS IS THE GENERAL CLEANUP PRIOR TO LEAVING THE INDEXING PROGRAM.*  70260000
**********************************************************************  70320000
INDXFIN  L     LWX,SVI             LOAD THAT BACK INTO 15.              70380000
         L     R1,4(LWX,MR)        NOW IF A IS NOT A NAMED ARRAY,       70440000
         LWTG                                                           70500000
INDXFIN1 L     R1,8(LWX,MR)        NOW I USE THE MKGARB PROGRAM TO DO   70560000
         ICALL MKGARB                                                   70620000
         L     LWX,SVI             THE INDEX LIST.                      70680000
         A     LWX,EIGHT           CHANGE THE STACK POINTER.            70740000
         ST    LWX,SVI             AND I LEAVE V ON THE STACK.          70800000
ELFIN    IRETURN                                                        70860000
AISVEC   EQU   *                                                        70920000
         L     R6,MRHO(A)          LOAD THE NUMBER OF ELEMENTS IN A.    70980000
         L     R2,MRHO(R8)         NOW SEE IF IT IS AN EMPTY LIST.      71040000
         LTR   R2,R2               XX                                   71100000
         BC    8,MPTYLS            XX                                   71160000
         BC    4,EVAL41            BRANCH IF I IS A NAMED ARRAY.        71220000
EVAL17   LA    R1,0(R2,MR)                                              71340000
         CLI   8(R1),X'02'                                              71400000
         BC    7,IND2                                                   71460000
         LA    R1,0(A,MR)                                               71520000
         CLI   8(R1),X'04'                                              71580000
         BC    8,EVAL50                                                 71640000
         CLI   8(R1),X'02'                                              71700000
         BC    7,IND2                                                   71760000
EVALII   EQU   *                                                        71820000
         SR    R7,R7               R7 IS ZERO FOR THIS CASE.            71880000
         LA    R3,16(R9,MR)        ABSOLUTE ADDRESS OF ELEMENT 0 OF A.  71940000
         LA    R9,INDXERR          LOAD THE INDEX ERROR ADDRESS FOR BCR 72000000
         LH    R5,MRANK(R2)        M-RELATIVE ADDRESS OF I.             72060000
         AR    R2,R5               ADD IN THE NUMBER OF DIMS.           72120000
         LA    R2,8(R2,MR)         ABS ADDR OF ELEMENT 0 OF I, LESS 4.  72180000
         LA    R4,4                PUT A CONSTANT FOUR IN R4.           72240000
         SR    R8,R8               GET A MINUS ONE IF ONE ORIGIN        72300000
         S     R8,IORIGIN          INDEXING, ZERO IF ZERO INDEXING.     72360000
         LCR   R5,R5               COMPLEMENT R5 (RHO RHO I) AND TEST   72420000
         BC    8,EVAL25            BRANCH IF I IS A SCALAR FROM LCR.    72480000
         L     R1,4(R2,R5)         LOAD LAST ELEMENT OF RANK VECTOR.    72540000
         LTR   R1,R1                                               3069 72600000
         BM    INDXERR             BRANCH IF MINUS DIMENSION       3069 72660000
         AR    R5,R4               EKE NEGATIVE OF RHO RHO I BY 4.      72720000
         BC    8,LOOP24            BRANCH IF I IS A VECTOR.             72780000
LOOP23   M     R0,4(R2,R5)         I IS MORE THAN A VEC, MPY BY DIM LNG 72840000
         LTR   R0,R0                                               3069 72900000
         BM    INDXERR             BRANCH IF MINUS DIMENSION       3069 72960000
         BZ    *+8                 BRANCH IF NO MPY OVERFLOW       3069 73020000
         L     R1,STRIKE           OVFLOW - SET TO CAUSE WSFULL    3069 73080000
         AR    R5,R4               EKE NEG NUMB BY FOUR AGAIN.          73140000
         BC    4,LOOP23            IF IT HAS NOT BECOME ZERO YET, DO MO 73200000
LOOP24   CL    R1,STRIKE           IS X/RHO I TOO LARGE            3069 73260000
         BNL   WSFULL              BRANCH IF TOO LARGE             3069 73320000
         SLL   R1,2                MPY X/RHO I BY 4                3069 73380000
         LA    R5,0(R1,R2)         ABS ADDR OF LAST ELEMENT IN I.       73440000
*********************************************************************** 73500000
* BASIC INDEXING LOOP FOR EVALUATION OF A SUBSCRIPTED VECTOR, ONE     * 73560000
* ORIGIN INDEXING, WHERE BOTH A AND I ARE INTEGER ARRAYS.             * 73620000
*********************************************************************** 73680000
         BC    15,EVAL27           COMMENCE INDEXING LOOP.              73740000
EVAL25   AR    R2,R4               ADD A FOUR TO GET IT RIGHT.          73800000
EVAL26   LR    R1,R8               A MINUS ONE FOR 1-ORIGIN INDEXING.   73860000
         A     R1,0(R2)            ADD SUBSCRIPT TO MINUS ONE.          73920000
         CLR   R1,R6               TEST FOR SUBSCRIPT OUT OF RANGE.     73980000
         BCR   10,R9               XX                                   74040000
         SLL   R1,2                MPY BY FOUR AND                      74100000
         L     R0,0(R1,R3)         FETCH A(I).                          74160000
         ST    R0,0(R2,R7)         STORE IT IN THE RIGHT PLACE.         74220000
EVAL27   BXLE  R2,R4,EVAL26        TEST FOR THE END OF THE LOOP.        74280000
* THE REGISTER USAGE IN THIS LOOP IS AS FOLLOWS:                        74340000
* R0 ... TRANSFER REGISTER FOR ELEMENT OF A                             74400000
* R1 ... CURRENT INDEX ELEMENT.                                         74460000
* R2 ... ABSOLUTE ADDRESS OF CURRENT INDEX ELEMENT.                     74520000
* R3 ... ABSOLUTE ADDRESS OF ELEMENT ZERO OF A.                         74580000
* R4 ... A CONSTANT -- PLUS FOUR.                                       74640000
* R5 ... ABSOLUTE ADDRESS OF LAST EKEMENT OF I.                         74700000
* R6 ... THE NUMBER OF ELEMENTS IN A.                                   74760000
* R7 ... THE ABSOLUTE ADDRESS OF ELEMENT ZERO OF THE PLACE TO RECEIVE * 74820000
* THE EVALUATED RESULT, MINUS THE ABSOLUTE ADDRESS OF ELEMENT ZERO OF I 74880000
* R9 ... THE ADDRESS OF WHERE TO GO WHEN AN INDEX ERROR IS DETECTED.    74940000
CLEEN1   L     R1,SVIA(LWX,MR)     THIS IS TO CLEAN UP THE STACK AND    75000000
         LWTG                                                           75060000
CLEEN2   AR    LWX,R4              GET A OFF THE STACK.                 75120000
         ST    LWX,SVI             XX                                   75180000
         L     R1,4(LWX,MR)        GET RID OF THE LIST, BUT SAVE I.     75240000
         N     R1,STRIKE           I IS NOW V.                          75300000
         L     R2,MRHO(R1)                                              75360000
         O     R2,FOURCON          FLAG THIS THING AS A TEMPORARY.      75420000
         ST    R2,4(LWX,MR)                                             75480000
         LA    R3,4(LWX)                                                75540000
         ST    R3,0(R2,MR)                                              75600000
         LA    R2,ELFIN            DO NOT COME BACK, INSTEAD EXIT.      75660000
         BC    15,LWMGN                                                 75720000
*********************************************************************** 75780000
* COME HERE IF THE SUBSCRIPT LIST WAS EMPTY ON EVALUATION.            * 75840000
*********************************************************************** 75900000
MPTYLS   EQU   *                                                        75960000
         L     R1,SVIX(LWX,MR)                                          76020000
         LWUG                                                           76080000
EVAL28   L     R1,SVIA(LWX,MR)                                          76140000
         ST    R1,SVIX(LWX,MR)                                          76200000
         LTR   R1,R1                                                    76260000
         BC    4,EVAL29                                                 76320000
         L     R2,0(R1,MR)                                              76440000
         A     R2,FOUR                                                  76500000
         ST    R2,0(R1,MR)                                              76560000
EVAL29   A     LWX,FOUR                                                 76620000
         ST    LWX,SVI                                                  76680000
         IRETURN                                                        76740000
*********************************************************************** 76800000
* I IS A NAMED INTEGER ARRAY, A IS A VECTOR, AND I IS TO BE COPIED    * 76860000
* OVER TO AN UNNAMED M-ENTRY OF INTEGERS.                             * 76920000
*********************************************************************** 76980000
EVAL41   DS    0H                                                       77040000
         L     R2,0(R2,MR)                                              77100000
         LA    R1,0(R2,MR)                                              77220000
         CLI   8(R1),X'02'                                              77280000
         BC    7,IND2                                                   77340000
         LA    R1,0(A,MR)                                               77400000
         CLI   8(R1),X'04'                                              77460000
         BC    8,EVAL50                                                 77520000
         CLI   8(R1),X'02'                                              77580000
         BC    7,IND2                                                   77640000
EVAL30   EQU   *                                                        77700000
         L     R1,MCOUNT(R2)                                            77760000
         SR    R2,R2                                                    77820000
         ICALL GETSPACE                                                 77880000
         L     LWX,SVI                                                  77940000
         L     R8,SVIX1(LWX,MR)    LIST ADDRESS.                        78000000
         N     R8,STRIKE           GET RID OF THOSE LEFT 8 BITS.        78060000
         L     R4,MRHO(R8)         GET THE OLD ARRAY ADDRESS.           78120000
         LA    R6,BOBO                                                  78180000
         LTR   R4,R4                                                    78240000
         BC    2,GOOCH                                                  78300000
LWMOVES  DS    0H                                                       78360000
         L     R4,M(R4)                                                 78420000
GOOCH    DS    0H                                                       78480000
         L     R3,MCOUNT(R4)       GET THE BYTE COUNT OF THIS ARRAY.    78540000
         AR    R4,MR               GET AN ABSOLUTE ADDRESS.             78600000
         LA    R5,0(R1,MR)         GET ANOTHER ABSOLUTE ADDRESS HERE.   78660000
         LWMOV R5,R4,R3,R2         MOVE ALL THAT STUFF TO ANOTHER PLACE 78720000
         BCR   15,R6                                                    78780000
BOBO     EQU   *                                                        78840000
         O     R1,FOURCON          FLAG THIS AS A TEMPORARY.            78900000
         ST    R1,MRHO(R8)                                              78960000
         LA    R0,MRHO-M(R8)       GET THE ADDRESS OF THE LIST ELEMENT. 79080000
         ST    R0,0(MR,R1)         MAKE M-ENTRY POINT TO LIST ELEMENT.  79140000
         A     LWX,FOUR                                                 79200000
         ST    LWX,SVI                                                  79260000
         L     R9,SVIA(LWX,MR)                                          79320000
         BMW   R9                                                       79380000
         L     R6,MRHO(R9)         LOAD THE NUMBER OF ELEMENTS IN A.    79440000
         BC    15,EVALII           NOW IT IS JUST LIKE AN UNNAMED I.    79500000
*********************************************************************** 79560000
* THIS SECTION IS TO PROCESS A VECTOR SUBSCRIPTED BY AN INTEGER ARRAY,* 79620000
* WHEN THE VECTOR IS A CHARACTER VECTOR.                                79680000
*********************************************************************** 79740000
EVAL50   DS    0H                                                       79800000
         LH    R3,MRANK(R2)        NUMBER OF DIMENSIONS OF I.           79860000
         AR    R2,R3               ADD FOUR X DIMS OF I.                79920000
         AR    R2,MR               MAKE AN ABSOLUTE ADDRESS.            79980000
         LA    R4,4                GET A CONSTANT FOUR IN R4.           80040000
         LCR   R5,R3               OBTAIN MINUS THE NUMBER OF DIMS.     80100000
         L     R1,12(R2,R5)        GET EITHER THE LENGTH ALONG THE      80160000
*                                  LAST DIMENSION OR THE FIRST ELEMENT  80220000
*                                  IN CASE I IS A SCALAR.               80280000
         BC    8,EVAL58            BRANCH IF I IS A SCALAR.             80340000
         LTR   R1,R1                                               3069 80400000
         BM    INDXERR             BRANCH IF MINUS DIMENSION       3069 80460000
         AR    R5,R4               ADD FOUR TO THE ADDRESS.             80520000
         BC    8,LOOP26            BRANCH IF I IS A VECTOR.             80580000
LOOP25   M     R0,12(R2,R5)        MPY DIMENSION LENGTHS TOGETHER.      80640000
         LTR   R0,R0                                               3069 80700000
         BM    INDXERR             BRANCH IF MINUS DIMENSION       3069 80760000
         BZ    *+8                 BRANCH IF NO MPY OVERFLOW       3069 80820000
         L     R1,STRIKE           OVFLOW - SET TO CAUSE WSFULL    3069 80880000
         AR    R5,R4               ADD 4 TO THE NEGATIVE NUMBER.        80940000
         BC    4,LOOP25            CONTINUE MPY UNTIL ALL X TOGETHER.   81000000
LOOP26   CL    R1,STRIKE           IS X/RHO I TOO LARGE            3069 81060000
         BNL   WSFULL              BRANCH IF TOO LARGE             3069 81120000
         ST    R1,SAVEM1           SAVE NO. ELEMENTS IN I          3069 81180000
*  NOW I HAVE TO GET SOME SPACE FOR THE RESULT. *                       81240000
* SPACE = 12+MRANK(R2)+R1.                      *                       81300000
         LA    R1,12(R1,R3)        XX                                   81360000
         SR    R2,R2               MAKE R2 ZERO.                        81420000
         ICALL GETSPACE            GET SOME SPACE.                      81480000
* NOW THE STACK LOOKS LIKE THIS:       *                                81540000
* 4+SVI -- NEW M-POINTER;              *                                81600000
* 8+SVI -- ARRAY POINTER;              *                                81660000
* 12+SVI -- ILIST POINTER.             *                                81720000
         L     LWX,SVI             RESTORE MY STACK POINTER.            81780000
         L     R3,8(LWX,MR)        GET THE POINTER TO THE ARRAY A.      81840000
         BMW   R3                  BASE MY WORKSPACE.                   81900000
         L     R6,MRHO(R3)         NUMBER OF ELEMENTS IN A.             81960000
         L     R2,12(LWX,MR)       ILIST POINTER.                       82020000
         L     R8,MRHO(R2)         THE POINTER TO I.                    82140000
         LTR   R2,R8               LETS SEE IF IT IS A NAMED ARRAY.     82200000
         BC    2,EVAL55            BRANCH IF IT IS NOT.                 82260000
         L     R2,0(R2,MR)         IT IS, NOW GET THE REAL ADDRESS.     82380000
EVAL55   DS    0H                                                       82440000
         L     R7,4(LWX,MR)        THE LOCATION OF THE NEW PLACE.       82500000
         AR    R7,MR               MAKE THAT ADDRESS ABSOLUTE.          82620000
         AR    R2,MR               MAKE THIS ONE ABSOLUTE TOO.          82680000
         LH    R1,10(R2)           FOUR X NUMBER OF DIMS IN I AGAIN.    82740000
         EX    R1,EVILMV           GET THOSE DIMENSIONS RIGHT.          82800000
         MVI   8(R7),X'04'         MAKE THE TYPE 4, FOR CHARACTERS.     82860000
         L     R5,SAVEM1           NUMBER OF ELEMENTS IN I.             82920000
         LA    R7,11(R7,R1)        R7 IS NOW ALL SET FOR THE LOOP.      82980000
         LA    R4,4                PUT A CONSTANT FOUR IN R4.           83040000
         LA    R3,16(R3,MR)        ABSOLUTE ADDRESS OF ELEMENT A(0).    83100000
         LA    R9,0(R5,R5)         R2 GETS R2+R1+12+4 X R5.             83160000
         AR    R2,R9               XX                                   83220000
         AR    R2,R9               XX                                   83280000
         LA    R2,08(R1,R2)        XX                                   83340000
         LA    R9,INDXERR          ADDRESS OF INDEX ERROR PLACE.        83400000
         LTR   R5,R5               LETS SEE HOW MANY THINGS ARE IN I.   83460000
         BC    8,EVAL53            IT BRANCHES IF I IS IOTA ZERO.       83520000
         SR    R8,R8               IT WAS NOT IOTA ZERO, NOW            83580000
         S     R8,IORIGIN          SET UP R8 WITH MINUS IORIGIN.        83640000
EVAL54   LR    R1,R8               LOAD THAT NEGATIVE ONE.       2.50   83700000
         A     R1,0(R2)            ADD THE SUBSCRIPT.            4.00   83760000
         CLR   R1,R6               SEE IF IT IS IN RANGE.        3.00   83820000
         BCR   10,R9               BRANCH ON INDEX ERROR.        2.75   83880000
         IC    R0,0(R1,R3)         GET A(I).                     5.50   83940000
         STC   R0,0(R5,R7)         STORE IT AWAY.                5.00   84000000
         SR    R2,R4               GO GET THE NEXT SUBSCRIPT.    3.25   84060000
         BCT   R5,EVAL54           LOOP CLOSURE.                 4.50   84120000
EVAL53   L     R3,12(LWX,MR)                                            84180000
         N     R3,STRIKE                                                84240000
         L     R1,MRHO(R3)                                              84300000
         LWTG                                                           84360000
         LR    R1,R3               GET IT INTO THE RIGHT REGISTER.      84420000
         BAL   R2,LWMGMK           MARK UNCONDITIONALLY GARBAGE.        84480000
         L     R1,8(LWX,MR)                                             84540000
         LWTG                                                           84600000
         L     R1,4(LWX,MR)                                             84660000
         O     R1,FOURCON          MARK THIS A TEMPORARY RESULT.        84720000
         ST    R1,12(LWX,MR)                                            84780000
         LA    LWX,8(LWX)          REMOVE A AND ILIST FROM THE STACK.   84840000
         ST    LWX,SVI             XX                                   84900000
         AR    LWX,R4              MAKE A BACK POINTER TO THE STACK.    84960000
         ST    LWX,0(R1,MR)        RIGHT BACK POINTER.                  85080000
         IRETURN                                                        85140000
EVILMV   MVC   8(4,R7),8(R2)       MOVE RANK VECTOR FROM I.             85200000
EVAL58   S     R1,IORIGIN          PROCESS COOL SCALAR SUBSCRIPT.       85260000
         CLR   R1,R6               USUAL RANGE TEST FOR INDEX ERROR.    85320000
         BC    10,INDXERR          XX                                   85380000
         AR    R1,R9               ADD BASE FOR A.                      85440000
         IC    R0,16(R1,MR)        GET A(I).                            85500000
         L     R1,12(R8,MR)        GET ADDRESS OF ILIST AND USE THE     85560000
         STC   R0,12(R8,MR)        SPACE OCCUPIED BY THE LIST TO STORE  85620000
         LWTG                                                           85680000
*        THE INITIAL REGISTER CONTENTS IN THE ABOVE LOOP ARE:           85740000
* R0 -- USED FOR DATA TRANSFERS, INITIAL CONTENTS DO NOT MATTER;        85800000
* R1 -- DITTO;                                                          85860000
* R2 -- ABSOLUTE ADDRESS OF LAST ELEMENT OF INDEX ARRAY;                85920000
* R3 -- ABSOLUTE ADDRESS OF A(0);                                       85980000
* R4 -- A CONSTANT FOUR;                                                86040000
* R5 -- NUMBER OF ELEMENTS IN THE INDEX ARRAY;                          86100000
* R6 -- NUMBER OF ELEMENTS IN ARRAY BEING INDEXED;                      86160000
* R7 --  ABSOLUTE ADDRESS OF ELEMENT ZERO OF RESULT) MINUS ONE;         86220000
* R8 -- USED FOR SUBTRACTING ONE IF THE INDEX ORIGIN IS ONE;            86280000
* R9 -- THE ADDRESS OF WHERE TO GO IF THERE IS AN INDEX ERROR.          86340000
EVAL59   LA    R0,8(LWX)           CREATE STACK POINTER FOR NEW THING.  86400000
         ST    R0,0(R8,MR)         XX                                   86460000
         LM    R0,R1,SIXTEEN       GET BYTE COUNT AND TYPE AND RANK.    86520000
         ST    R0,4(R8,MR)         PLACE THE BYTE COUNT RIGHT.          86580000
         ST    R1,8(R8,MR)         AND THE TYPE AND RANK.               86640000
         L     R1,4(LWX,MR)        NOW I HAVE TO GET RID OF A IF NEC.   86700000
         LWTG                                                           86760000
EVAL60   AR    LWX,R4              EKE LWX BY FOUR AND STORE THE        86820000
         ST    LWX,SVI             NEW SVI.                             86880000
         IRETURN                                                        86940000
BASES    L     LWX,SVI                                                  87000000
         BASE  A,4                                                      87060000
         BASE  I,8                                                      87120000
         BASE  V,12                                                     87180000
         BCR   15,R1                                                    87240000
LWMGLTR  LTR   R1,R1               SEE IF IT IS A NAMED ARRAY.          87300000
LWMGBCR  BCR   4,R2                IF IT IS, LEAVE IT ALONE.            87360000
LWMGN    N     R1,STRIKE           REMOVE THE BITS SO MKG WILL WORK.    87420000
LWMGMK   MKG   R1                                                       87480000
         BCR   15,R2               GO TO FROM WHENCE IT CAME.           87540000
WSFULL   LA    R1,EMFULL           WS FULL                         3069 87600000
         B     ERRCALL                                             3069 87660000
SYNTERR  LA    R1,ESYNTAX                                          3561 87720000
         B     ERRCALL                                             3561 87780000
INDXERR  LA    R1,EINDEX           INDEX ERROR.                         87840000
         BC    15,ERRCALL                                               87900000
RNKERR   LA    R1,ERANK            RANK ERROR.                          87960000
         BC    15,ERRCALL                                               88020000
LNGERR   LA    R1,ELENGTH          LENGTH ERROR.                        88080000
         BC    15,ERRCALL                                               88140000
TYPERR   LA    R1,ERANGE           DOMAIN ERROR                         88200000
         BC    15,ERRCALL                                               88260000
NONCERR  LA    R1,ENONCE           NONCE ERROR.                         88320000
         BC    15,ERRCALL                                               88380000
VALUERR  LA    R1,EVALUE           VALUE ERROR, TOO BAD.                88440000
ERRCALL  ICALL ERROR                                                    88500000
         CNOP  0,4                                                      88560000
ONE      DC    XL4'00000001'                                            88620000
FOUR     DC    XL4'00000004'       A CONSTANT FOUR.                     88680000
FIVECON  DC    XL4'05000000'                                            88740000
SEVEN    DC    XL4'00000007'       A SEVEN FOR SUNDRY USES.             88800000
EIGHT    DC    XL4'00000008'                                            88860000
RIGHTBYT DC    XL4'01204008'       (1/8,4,8,1)                          88920000
STRIKE   DC    XL4'00FFFFFF'       TO REMOVE THE LEFT EIGHT BITS.       88980000
SIXTEEN  DC    XL4'00000010'       SIXTEEN IN BASE SIXTEEN.             89040000
*              BEWARE, THE CONSTANT SIXTEEN AND THE FOLLOWING         * 89100000
*              CONSTANT FOURCON ARE LOADED WITH A LOAD MULTIPLE       * 89160000
*              INSTRUCTION, AND SO MUST NOT BE SEPARATED.             * 89220000
FOURCON  DC    XL4'04000000'                                            89280000
TWENTY8  DC    XL4'0000001C'       TWENTY EIGHT IN BASE SIXTEEN REPRESE 89340000
FLOAT1   DC    E'1'                                                     89400000
NEGNUM   DC    XL8'C910000000000000'  MINUS 2*32.                       89460000
DIDLTYP  DC    XL4'01070900'                                            89520000
         DC    XL4'05020A00'                                            89580000
         DC    XL4'06080300'                                            89640000
         DC    XL4'00000004'                                            89700000
         LTORG                                                          89760000
INDEXDMY DSECT                                                          89820000
FUG1     EQU   *                                                        89880000
VALUE    DC    XL8'0000000000000000'                                    89940000
AS       DC    XL4'00000000'                                            90000000
IS       DC    XL4'00000000'                                            90060000
VKS      DC    XL4'00000000'                                            90120000
WKS      DC    XL4'00000000'                                            90180000
WKLIM    DC    XL4'00000000'                                            90240000
E        DC    (16*8)XL4'00000000' SPACE FOR TEMPS, ONE SET PER DIM     90300000
EEND     EQU   *-28                                                     90360000
WK1      EQU   EEND-E                                                   90420000
F        DC    16XL4'00000000'     THIS SPACE IS TO COLLECT RANK VECTOR 90480000
FEND     EQU   *-4                                                      90540000
VK1      EQU   FEND-F                                                   90600000
ACMPS    DC    XL4'00000000'                                            90660000
VCMPS    DC    XL4'00000000'                                            90720000
DOWNADR  DC    XL4'00000000'                                            90780000
DOWNYSV  DC    XL4'00000000'                                            90840000
SAVEM1   DC    XL4'00000000'                                            90900000
FUDGE    DC    XL4'00000000'                                     -      90960000
SCRAM    DC    XL4'00000000'                                            91020000
VCMPS2   DC    XL4'00000000'                                            91080000
SWICH    DC    XL1'00'                                                  91140000
S        DC    XL1'00'                                                  91200000
OFLOWSW  DC    XL1'00'             MULTIPLY-OVERFLOW SWITCH        6002 91260000
LWDSECT  EQU   *                                                        91320000
FUG2     EQU   *                                                        91380000
         END                                                            91440000
./  ADD    NAME=APLSMDIV
MDIV     TITLE 'DOMINO --   M A T R I X     D I V I D E'                00150000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00300000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00450000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00600000
EXMMATD  CSECT                                                          00900000
         PRINT OFF       APLDEFN, OPSECT                                01050000
         COPY APLDEFN                                                   01200000
         COPY  OPSECT                                                   01350000
         TITLE 'DOMINO --   M A T R I X     D I V I D E'                01500000
EXMMATD  CSECT                                                          01650000
         PRINT ON                                                       01800000
         ENTRY EXDMATD                                                  01950000
         EXTRN ERROR                                                    02100000
         EXTRN FETCH                                                    02250000
         EXTRN OPSPACE                                                  02400000
         EXTRN SQRT                                                     02550000
         USING OPSECT-16,13                                             02700000
*                                                                       02850000
*        ENTRY FOR MONADIC MATRIX DIVIDE                                03000000
*                                                                       03150000
         USING EXMMATD,9                                                03300000
         ST    LKR,MDLKR           STORE RETURN                         03450000
         MVI   DYDFLAG,0           SET MONADIC FLAG                     03600000
         L     6,RHBASE                                                 03750000
         LA    6,12(6)                                                  03900000
         L     1,M(6)                                                   04050000
         ST    1,PPP               P = NUMBER OF COL'S OF RESULT        04200000
         MH    1,PPP+2                                                  04350000
         LA    2,8                                                      04500000
         ST    2,RRANK             RANK OF RESULT IS 2                  04650000
         BAL   9,MDCOM             MERGE INTO COMMON ROUTINE            04800000
*                                                                       04950000
*        ENTRY FOR DYADIC MATRIX DIVIDE                                 05100000
*                                                                       05250000
         USING EXDMATD,9                                                05400000
EXDMATD  ST    LKR,MDLKR           STORE RETURN                         05550000
*        CONFORMABILITY AND RANK CHECKING                               05700000
         MVI   DYDFLAG,1           SET DYADIC FLAG                      05850000
         L     2,LHBASE                                                 06000000
         LA    2,12(2)                                                  06150000
         CLI   LHRANK+3,8                                               06300000
         BH    RANKERR             LHRANK GT 2                          06450000
         BE    GETP                                                     06600000
         CLI   LHRANK+3,4                                               06750000
         BL    RANKERR             LHRANK LESS THAN 1                   06900000
         LA    1,1                                                      07050000
         ST    1,PPP               SET P=NO OF RIGHT HAND SIDES TO 1    07200000
         B     GETRRANK                                                 07350000
GETP     L     1,M+4(2)                                                 07500000
         ST    1,PPP               STORE NO OF RIGHT HAND SIDES IN P    07650000
GETRRANK L     1,LHRANK                                                 07800000
         ST    1,RRANK                                                  07950000
         L     6,RHBASE                                                 08100000
         LA    6,12(6)                                                  08250000
         L     3,M(6)                                                   08400000
         C     3,M(2)                                                   08550000
         BNE   LENERR              UNEQUAL NUMBER OF ROWS IN A AND B    08700000
         L     1,LHXRHO                                                 08850000
MDCOM    A     1,RHXRHO            NUMBER OF WORDS FOR A,B              09000000
         ST    1,MDTEMP            START OF COMMON ROUTINE              09150000
         CLI   RHRANK+3,8                                               09300000
         BNE   RANKERR             RHRANK NOT 2                         09450000
         L     3,M(6)                                                   09600000
         ST    3,MM                MM = NUMBER OF ROWS OF A             09750000
         L     4,M+4(6)                                                 09900000
         ST    4,N                 N = NUMBER OF COLS OF A              10050000
         CR    3,4                                                      10200000
         BL    LENERR              A HAS FEWER ROWS THAN COLUMNS        10350000
         CLI   INDBASE,0                                                10500000
         BNE   INDXERR             OPERATOR INDEX NOT ELIDED            10650000
*                                                                       10800000
*        GET SPACE TO DO ALL WORK IN                                    10950000
*        R1 HAS NUMBER OF DOUBLE WORDS IN A AND B                       11100000
         LA    1,1(1)              ONE MORE IF NEEDED TO GO TO DBL      11250000
*                                  WORD BOUNDARY                        11400000
         L     2,N                                                      11550000
         A     2,PPP               N+P                                  11700000
         C     2,MM                TEMP VECTOR Y IS M MAX N+P DBL WDS   11850000
         BNL   *+8                                                      12000000
         L     2,MM                                                     12150000
         AR    1,2                                                      12300000
         A     1,N                 N WORDS FOR FACTOR                   12450000
         L     2,N                                                      12600000
         LA    2,1(2)                                                   12750000
         SRL   2,1                                                      12900000
         AR    1,2                 N/2 WORDS FOR  PIVOT RECORD          13050000
         LA    2,2                 RANK IS 2                            13200000
         LA    3,3                 TYPE IS FLOATING                     13350000
         L     10,=A(OPSPACE)                                           13500000
         BALR  LKR,10                                                   13650000
         ST    1,RBASE             BASE FOR WORKING SPACE               13800000
         LA    1,20(1)             NORMAL DATA BASE                     13950000
         LA    1,4(1)                                                   14100000
         N     1,ALLBUT7                                                14250000
         ST    1,ABDATA            DATA STARTS ON DBL WORD BOUNDARY     14400000
         L     2,MDTEMP            NO OF WORDS IN A,B                   14550000
         SLL   2,3                 TIMES 8                              14700000
         AR    1,2                                                      14850000
         ST    1,YBASE             BASE FOR Y VECTOR                    15000000
         L     2,N                                                      15150000
         SLL   2,3                                                      15300000
         ST    2,N8                8*N                                  15450000
         L     3,PPP                                                    15600000
         SLL   3,3                                                      15750000
         ST    3,P8                8*P                                  15900000
         AR    3,2                                                      16050000
         ST    3,NP8               8*(N+P)                              16200000
         L     2,MM                                                     16350000
         SLL   2,3                                                      16500000
         CR    3,2                                                      16650000
         BNL   *+6                                                      16800000
         LR    3,2                                                      16950000
         AR    1,3                                                      17100000
         ST    1,FACTBASE          BASE FOR VECTOR OF SCALE FACTORS     17250000
         A     1,N8                                                     17400000
         ST    1,PPBASE            BASE FOR INTERCHANGE ARRAY           17550000
*                                                                       17700000
*        SET UP RESULT DSECT AND M-ENTRY                                17850000
         LA    1,3                                                      18000000
         ST    1,RSTYPE                                                 18150000
         L     1,N                                                      18300000
         L     6,RBASE                                                  18450000
         ST    1,M+12(6)           STORE  1ST DIMENSION                 18600000
         L     1,PPP                                                    18750000
         CLI   RRANK+3,8                                                18900000
         BNE   *+8                                                      19050000
         ST    1,M+16(6)           STORE 2ND DIMENSION IF ANY           19200000
         MH    1,N+2                                                    19350000
         ST    1,RXRHO                                                  19500000
         LTR   1,1                                                      19650000
         BNZ   CONT                REAL WORK TO DO                      19800000
         L     10,RBASE                                                 19950000
         A     10,RRANK                                                 20100000
         LA    10,12(10)           R10 POINTS  TO FIRST WD AFTER RES    20250000
         B     CLEANUP             FINISH CLEANUP FOR EMPTY RESULT      20400000
CONT     L     3,NP8               COMPUTE A LOOP CONTROL CONSTANT      20550000
         MH    3,MM+2                                                   20700000
         LA    4,8                                                      20850000
         SR    3,4                                                      21000000
         A     3,ABDATA                                                 21150000
         ST    3,MNP8              BASE+(8*M*(N+P))-8,  LAST ELEMENT    21300000
*                                  OF A,B  (B JOINED TO RIGHT OF A)     21450000
*                                                                       21600000
*        SELECT ADJOINING ROUTINE                                       21750000
         CLI   DYDFLAG,1                                                21900000
         BNE   ADJ2                MUST GENERATE IDENTITY FOR B         22050000
         CLI   RHTYPE+3,3                                               22200000
         BNE   ADJ2                A NOT FLOATING, MUST BE FETCHED      22350000
         CLI   LHTYPE+3,3                                               22500000
         BNE   ADJ2                B NOT FLOATING, MUST BE FETCHED      22650000
*                                                                       22800000
*        CAN USE MVC LOOPS TO ADJOIN B TO A                             22950000
         L     7,ABDATA                                                 23100000
         L     8,RHBASE                                                 23250000
         LA    8,12(8)                                                  23400000
         A     8,RHRANK            BASE OF DATA FOR A                   23550000
         L     6,N8                                                     23700000
         MH    6,MM+2                                                   23850000
         AR    6,8                 UPPER LIMIT FOR A                    24000000
         L     10,LHBASE                                                24150000
         LA    10,12(10)                                                24300000
         A     10,LHRANK           BASE OF DATA FOR B                   24450000
ADJLOOP1 L     2,N8                LENGTH OF ROW  OF A                  24600000
         LR    3,8                                                      24750000
         AR    3,MR                ABSOLUTE SOURCE POINTER TO A         24900000
         LR    4,7                                                      25050000
         AR    4,MR                ABSOLUTE SINK                        25200000
         BAL   LKR,MVCLOOP         MOVE ROW OF A                        25350000
         A     8,N8                                                     25500000
         A     7,N8                INCREMENT POINTERS                   25650000
         L     2,P8                LENGTH OF ROW OF B                   25800000
         LR    3,10                                                     25950000
         AR    3,MR                ABSOLUTE SOURCE FOR A                26100000
         LR    4,7                                                      26250000
         AR    4,MR                ABSOLUTE SINK                        26400000
         BAL   LKR,MVCLOOP         MOVE ROW OF B                        26550000
         A     10,P8                                                    26700000
         A     7,P8                INCREMENT POINTERS                   26850000
         QUEND                                                          27000000
         CR    8,6                 TEST AND LOOP                        27150000
         BL    ADJLOOP1                                                 27300000
         B     GO                  DONE HOUSEKEEPING                    27450000
*                                                                       27600000
*        ADJOIN ROUTINE USED IF A OR B MUST BE FETCHED OR IF            27750000
*        B MUST BE GENERATED                                            27900000
ADJ2     L     10,ABDATA           BASE FOR WORKING DATA                28050000
         L     8,RHBASE                                                 28200000
         LA    8,12(8)                                                  28350000
         A     8,RHRANK                                                 28500000
         ST    8,MDTEMP            BASE FOR DATA IN A                   28650000
         CLI   DYDFLAG,1                                                28800000
         BNE   MON1                                                     28950000
         L     8,LHBASE                                                 29100000
         LA    8,12(8)                                                  29250000
         A     8,LHRANK                                                 29400000
         ST    8,MDTEMP+4          BASE FOR DATA IN B                   29550000
MON1     SR    8,8                 ROW COUNTER = 0                      29700000
         LA    6,1                                                      29850000
ADJLOOP2 SR    5,5                 COL CNTR = 0                         30000000
         L     7,N                                                      30150000
         SR    7,6                 LIMIT FOR LOOP                       30300000
         L     4,MDTEMP            INITIALIZE FETCH FOR A               30450000
         L     3,RCTYPE                                                 30600000
         LR    2,8                                                      30750000
         MH    2,N+2                                                    30900000
MOVEA    ICALL FETCH                                                    31050000
         STD   0,M(10)             STORE ELEMENT                        31200000
         LA    10,8(10)            INCREMENT AB POINTER                 31350000
         AR    2,6                 INCREMENT FETCH INDEX                31500000
         BXLE  5,6,MOVEA           INCR COL CNTR & LOOP                 31650000
         SR    5,5                 COL CNTR = 0                         31800000
         L     7,PPP                                                    31950000
         SR    7,6                 LIMIT FOR LOOP                       32100000
         L     4,MDTEMP+4                                               32250000
         LR    2,8                                                      32400000
         MH    2,PPP+2             INITIALIZE FETCH FOR B               32550000
         L     3,LCTYPE            FETCH TYPE  FOR B                    32700000
MOVEB    CLI   DYDFLAG,1                                                32850000
         BE    CALLF                                                    33000000
         SDR   0,0                 PICK UP IDENTITY ELEMENT             33150000
         CR    8,5                                                      33300000
         BNE   STORB                                                    33450000
         LD    0,DONE              LOAD DIAGONAL ELEMENT                33600000
         B     STORB                                                    33750000
CALLF    ICALL FETCH               FETCH ELEMENT OF B                   33900000
STORB    STD   0,M(10)             STORE ELEMENT OF B                   34050000
         LA    10,8(10)            INCREMENT AB POINTER                 34200000
         AR    2,6                 INCREMENT FETCH INDEX                34350000
         BXLE  5,6,MOVEB           INCR COL CNTR & LOOP                 34500000
         AR    8,6                 INCR ROW CNTR                        34650000
         QUEND                                                          34800000
         C     8,MM                TEST & LOOP                          34950000
         BL    ADJLOOP2                                                 35100000
*                                                                       35250000
*        NOW START REAL WORK OF MATRIX DIVIDE OPERATOR                  35400000
GO       L     8,ABDATA            R8 CONTAINS DATA BASE                35550000
*                                                                       35700000
*        INITIALIZE COL INTERCHANGE RECORD                              35850000
         LA    0,8                                                      36000000
         LA    3,4                                                      36150000
         L     1,N8                                                     36300000
         SR    1,0                 UPPER LIMIT FOR LOOP                 36450000
         L     4,PPBASE                                                 36600000
         SR    2,2                                                      36750000
INITPP   ST    2,M(4)              PP(I) = 8*I                          36900000
         AR    4,3                                                      37050000
         BXLE  2,0,INITPP                                               37200000
*                                                                       37350000
*                                                                       37500000
*        COMMON LOOP CONTROL USED UNTIL BACKSOLVE PART OF THE PROGRAM   37650000
*        ROW LOOP,   R4 IS POINTER R2 IS ROW INCR 8*(N+P)               37800000
*              R3 IS LIMIT MNP8                                         37950000
*        COLUMN LOOP, R5 IS COL POINTER, R6 IS INCR 8 ,                 38100000
*              R7 IS COL LIMIT (EITHER 8*(N-1) OR 8*(N+P-1) )           38250000
         L     2,NP8                                                    38400000
         L     3,MNP8                                                   38550000
         LA    6,8                                                      38700000
         L     7,N8                                                     38850000
         SR    7,6                 SET COLUMN LOOP TO N                 39000000
*                                                                       39150000
*        SCALE COLUMNS SO THAT EACH COLUMN HAS AT LEAST ONE ELEMENT     39300000
*        WHICH IS THE MAXIMUM IN ITS ROW.                               39450000
*                                                                       39600000
*        GET ROW MAXIMUMS                                               39750000
         L     4,ABDATA            SET ROW CONTROL                      39900000
         L     8,YBASE                                                  40050000
         SDR   6,6                                                      40200000
MD0      LR    10,4                SET COL CONTROL                      40350000
         SR    5,5                                                      40500000
         SDR   0,0                                                      40650000
         SDR   4,4                 INITIALIZE ROW SUM              3070 40800000
MD01     LD    2,M(10)             LOAD NEXT COL ELEMENT                40950000
         LPER  2,2                                                      41100000
         ADR   4,2                 ADD TO ROW SUM                  3070 41250000
         CDR   0,2                                                      41400000
         BNL   *+6                                                      41550000
         LDR   0,2                 REPLACE IF LARGER                    41700000
         AR    10,6                                                     41850000
         BXLE  5,6,MD01            COL LOOP                             42000000
         STD   0,M(8)              SAVE ROW MAX IN Y                    42150000
         CDR   6,4                 COMPARE WITH MAX ROW SUM        3070 42300000
         BNL   *+6                 REPLACE IF LARGER                    42450000
         LDR   6,4                                                 3070 42600000
         AR    8,6                                                      42750000
         QUEND                                                          42900000
         BXLE  4,2,MD0             ROW LOOP                             43050000
         LD    0,CPUTFUZZ          ABSOLUTE FUZZ                   3070 43200000
         AD    0,EPSILON           ADD 16**-13 IN CASE FUZZ IS 0   3070 43350000
         MDR   6,0                 MULTIPLY MAXNORM BY FUZZ        3070 43500000
         STD   6,MAXNORM           CRITERION FOR SINGULARITY            43650000
*        GET SCALE FACTOR                                               43800000
         SDR   6,6                 F6 HAS FLOATING 0               3070 43950000
         SR    5,5                 SET COL CONTROL                      44100000
         L     10,FACTBASE                                              44250000
MD02     L     4,ABDATA                                                 44400000
         AR    4,5                 SET ROW CONTROL                      44550000
         L     8,YBASE                                                  44700000
         SDR   0,0                                                      44850000
MD3      LD    2,M(4)                                                   45000000
         CDR   2,6                 COMPARE WITH ZERO               3070 45150000
         BE    MD35                SKIP DIVIDE IF ZERO             3070 45300000
         DD    2,M(8)              DIVIDE BY MAX ROW ELEMENT            45450000
         LPER  2,2                                                      45600000
         CDR   0,2                                                      45750000
         BNL   *+6                                                      45900000
         LDR   0,2                 SCALE FACTOR IS MAX OF THESE RATIOS  46050000
MD35     AR    8,6                                                 3070 46200000
         BXLE  4,2,MD3                                                  46350000
         STD   0,M(10)             SAVE IN FACTOR                       46500000
         L     4,ABDATA                                                 46650000
         AR    4,5                 SET ROW CONTROL AGAIN                46800000
MD4      LD    2,M(4)                                                   46950000
         DDR   2,0                 SCALE COLUMN                         47100000
         STD   2,M(4)                                                   47250000
         BXLE  4,2,MD4             ROW LOOP                             47400000
         AR    10,6                                                     47550000
         QUEND                                                          47700000
         BXLE  5,6,MD02            COL LOOP                             47850000
*                                                                       48000000
*        START MAJOR LOOP TO DO HOUSEHOLDER TRANSFORMATIONS             48150000
*        R0 CONTAINS POINTER TO KTH COLUMN 8*(K-1)                      48300000
*        R1 CONTAINS POINTER TO KTH ROW BASE+8*(N+P)*(K-1)              48450000
*                                                                       48600000
         SR    0,0                                                      48750000
         L     1,ABDATA            INITIALIZE R0, R1                    48900000
TRNGIZE  LR    8,1                 INITIALIZE PIVOT ROW & COLUMN        49050000
         LR    10,0                                                     49200000
         L     7,N8                SET COLUMN LIMIT TO N                49350000
         SR    7,6                                                      49500000
*        LOOP FOR MAXIMUM PIVOT ELEMENT                                 49650000
         LR    5,0                                                      49800000
         SDR   0,0                 INITIALIZE TO 0                      49950000
MD1      LR    4,1                                                      50100000
         AR    4,5                                                      50250000
MD2      LD    2,M(4)                                                   50400000
         LPER  2,2                 ABS A(I,J)                           50550000
         CDR   0,2                                                      50700000
         BNL   BIGR                BRANCH IF F0 ALREADY MAX             50850000
         LDR   0,2                 F0 = NEW MAX                         51000000
         LR    8,4                 REMEMBER ITS POSITION                51150000
         LR    10,5                                                     51300000
BIGR     BXLE  4,2,MD2             ROW LOOP                             51450000
         QUEND                                                          51600000
         BXLE  5,6,MD1             COL LOOP                             51750000
*                                                                       51900000
*        MAX ELEMENT IN F0, MATRIX IS ESSENTIALLY SINGULAR IF           52050000
*        IT IS LESS THAN THE MAXIMUM ROW SUM TIMES                 3070 52200000
*        CPUTFUZZ + EPSILON.                                       3070 52350000
*                                                                       52500000
         CD    0,MAXNORM                                                52650000
         BNH   RNGERR                                                   52800000
         SR    8,10                                                     52950000
         ST    8,MDPI              STORE PIVOT ROW INDICATOR            53100000
         CR    0,10                                                     53250000
         BE    NOCOLI                                                   53400000
*        DO COLUMN INTERCHANGE                                          53550000
         L     5,PPBASE                                                 53700000
         LR    8,10                                                     53850000
         SRL   8,1                                                      54000000
         AR    8,5                 POINTER TO PP(PJ)                    54150000
         LR    4,0                                                      54300000
         SRL   4,1                                                      54450000
         AR    4,5                 POINTER TO PP(J)                     54600000
         L     5,M(8)                                                   54750000
         L     6,M(4)              INTERCHANGE PIVOT RECORDS            54900000
         ST    6,M(8)                                                   55050000
         ST    5,M(4)                                                   55200000
         LA    6,8                 RESTORE R6 TO 8                      55350000
         L     4,ABDATA            CONTROL FOR INTERCHANGE LOOP         55500000
         AR    10,4                                                     55650000
         AR    4,0                                                      55800000
MD5      LD    0,M(4)              ACTUAL INTERCHANGE                   55950000
         LD    2,M(10)                                                  56100000
         STD   2,M(4)                                                   56250000
         STD   0,M(10)                                                  56400000
         AR    10,2                                                     56550000
         BXLE  4,2,MD5             ROW LOOP                             56700000
NOCOLI   C     1,MDPI                                                   56850000
         BE    NOROWI                                                   57000000
*        DO ROW INTERCHANGE                                             57150000
         STM   0,3,MDTEMP                                               57300000
         LR    3,1                                                      57450000
         AR    3,MR                ABS POINTER TO KTH ROW               57600000
         L     4,YBASE                                                  57750000
         AR    4,MR                ABS POINTER TO Y                     57900000
         BAL   LKR,MVCLOOP         MOVE KTH ROW TO Y                    58050000
         L     2,NP8                                                    58200000
         L     3,MDPI                                                   58350000
         AR    3,MR                ABS POINTER TO PIVOT ROW             58500000
         L     4,MDTEMP+4                                               58650000
         AR    4,MR                ABS POINTER TO KTH ROW               58800000
         BAL   LKR,MVCLOOP         MOVE PIVOT ROW TO KTH ROW            58950000
         L     2,NP8                                                    59100000
         L     3,YBASE                                                  59250000
         AR    3,MR                ABS POINTER TO Y                     59400000
         L     4,MDPI                                                   59550000
         AR    4,MR                ABS POINTER TO  PIVOT ROW            59700000
         BAL   LKR,MVCLOOP         MOVE Y TO PIVOT ROW                  59850000
         LM    0,3,MDTEMP                                               60000000
*                                                                       60150000
*        READY TO DO ACTUAL HOUS. TRANSFORMATION                        60300000
NOROWI   LR    4,0                                                      60450000
         AR    4,1                                                      60600000
         LD    4,M(4)                                                   60750000
         STD   4,AKK               CURRENT A(K,K)                       60900000
         SDR   0,0                                                      61050000
MD11     LD    2,M(4)                                                   61200000
         MDR   2,2                 LOOP TO FORM SUM OF SQUARES OF       61350000
         ADR   0,2                 KTH COLUMN  STARTING AT A(K,K)       61500000
         BXLE  4,2,MD11                                                 61650000
         STD   0,SIGMA             SIGMA = SUMSQ                        61800000
         LDR   2,0                                                      61950000
         STM   0,3,MDTEMP                                               62100000
         L     4,=A(SQRT)          GET SQRT SIGMA                       62250000
         BALR  3,4                                                      62400000
         LM    0,3,MDTEMP                                               62550000
         LD    4,AKK                                                    62700000
         LTER  4,4                                                      62850000
         BM    *+6                                                      63000000
         LCER  0,0                 SET SIGN OPPOSITE THAT OF AKK        63150000
         STD   0,ALFA              STORE AS ALFA                        63300000
         MDR   0,4                                                      63450000
         LD    2,SIGMA                                                  63600000
         SDR   2,0                                                      63750000
         LD    6,DONE              BETA= 1/SIGMA-ALFA*AKK               63900000
         DDR   6,2                 BETA IS IN F6                        64050000
         SD    4,ALFA                                                   64200000
         LR    4,0                                                      64350000
         AR    4,1                                                      64500000
         STD   4,M(4)              DURING REST OF CALC OF HOUS TRANS    64650000
*                                  A(K,K) IS AKK-ALFA                   64800000
*                                                                       64950000
*        LOOP TO FORM Y VECTOR, ESSENTIALLY AN INNER PRODUCT            65100000
*        OF THE KTH COLUMN WITH  THE LOWER RIGHT SUBMATRIX.             65250000
         LR    5,0                 R5 CORRESPONDS TO OUTER LOOP J       65400000
         L     7,NP8               CHANGE COLUMN LIMIT TO N+P           65550000
         SR    7,6                                                      65700000
         B     MD14A                                                    65850000
MD14     LR    4,1                                                      66000000
         AR    4,5                 FINAL I VALUE                        66150000
         LR    10,1                R10 I INDEX FOR  A(I,K)              66300000
         AR    10,0                                                     66450000
         SDR   0,0                 S = 0                                66600000
MD15     LD    2,M(10)             A(I,K)                               66750000
         MD    2,M(4)              *A(I,J)                              66900000
         ADR   0,2                 S = S+PRODUCT                        67050000
         AR    10,2                INCREMENT I FOR KTH COL              67200000
         BXLE  4,2,MD15            INCR I FOR JTH COL & LOOP            67350000
         MDR   0,6                 S = S*BETA                           67500000
         L     4,YBASE                                                  67650000
         AR    4,5                                                      67800000
         STD   0,M(4)              Y(J) = S                             67950000
         QUEND                                                          68100000
MD14A    BXLE  5,6,MD14            INCR J AND LOOP                      68250000
*                                                                       68400000
*        LOOP TO FORM OUTER PRODUCT AND SUBTRACT                        68550000
         LR    5,0                 SAME LOOP STRUCTURE AS ABOVE         68700000
         B     MD17A                                                    68850000
MD17     L     4,YBASE                                                  69000000
         AR    4,5                                                      69150000
         LD    6,M(4)              F6 = Y(J)                            69300000
         LR    4,1                                                      69450000
         AR    4,5                 INITIALIZE I                         69600000
         LR    10,1                                                     69750000
         AR    10,0                                                     69900000
MD18     LD    2,M(4)              A(I,J)                               70050000
         LD    0,M(10)             A(I,K)                               70200000
         MDR   0,6                 *Y(J)                                70350000
         SDR   2,0                                                      70500000
         STD   2,M(4)              STORE NEW A(I,J)                     70650000
         AR    10,2                INCR I IN 2 FORMS                    70800000
         BXLE  4,2,MD18            AND LOOP                             70950000
         QUEND                                                          71100000
MD17A    BXLE  5,6,MD17            INCR J AND LOOP                      71250000
*                                                                       71400000
*        RESTORE K,K ELEMENT & LOOP TO NEXT HOUS. TRANSFORMATION        71550000
         LR    4,0                                                      71700000
         AR    4,1                                                      71850000
         LD    0,ALFA                                                   72000000
         STD   0,M(4)              A(K,K) = ALFA                        72150000
         A     1,NP8                                                    72300000
         AR    0,6                 INCR K IN R0,R1                      72450000
         C     0,N8                                                     72600000
         BL    TRNGIZE                                                  72750000
*                                                                       72900000
*        BACK SOLVE IN PLACE ONE COLUMN AT A TIME                       73050000
*        R0 = L,RIGHT HAND SIDE CNTR STORED AS 8*(N+L)                  73200000
*        R1 = I COLUMN INDICATOR                                        73350000
*        R2 = I ROW INDICATOR                                           73500000
*        R3 = I COL DECREMENT AND LIMIT   -8                            73650000
*        R4 = TEMP                                                      73800000
*        R5 = J COL INDICATOR (INNER LOOP)                              73950000
*        R6 = J COL INCREMENT      8                                    74100000
*        R7 = J COL LIMIT                                               74250000
*        R8 = I ROW INCREMENT   NP8                                     74400000
*        R10 USED AS TEMPORARY                                          74550000
         L     0,N8                EQUIVALENT TO L=0                    74700000
NEXTL    L     1,N8                                                     74850000
         LA    3,8                                                      75000000
         LCR   3,3                                                      75150000
         AR    1,3                                                      75300000
         L     8,NP8                                                    75450000
         LR    2,8                                                      75600000
         MH    2,N+2                                                    75750000
         SR    2,8                                                      75900000
         A     2,ABDATA            R2 POINTS TO NTH ROW                 76050000
         L     4,YBASE                                                  76200000
         AR    4,1                 R4 POINTS TO Y(N)                    76350000
MD25     LR    5,1                 SET R5-R7 TO CONTROL INNER LOOP      76500000
         AR    5,2                                                      76650000
         L     7,N8                                                     76800000
         SR    7,6                                                      76950000
         AR    7,2                                                      77100000
         LR    10,2                ROW POINTER                          77250000
         AR    10,0                PLUS N+L                             77400000
         LD    0,M(10)             F0 = A(I,N+L)                        77550000
         LR    10,4                                                     77700000
         AR    10,6                INITIALIZE R10 FOR Y POINTER         77850000
MD26     BXH   5,6,FIN26           INCR AND TEST END OF LOOP            78000000
         LD    2,M(5)                                                   78150000
         MD    2,M(10)             F0 = F0-A(I,J)*Y(J)                  78300000
         SDR   0,2                                                      78450000
         AR    10,6                                                     78600000
         B     MD26                LOOP                                 78750000
FIN26    LR    10,2                ROW POINTER                          78900000
         AR    10,1                COLUMN POINTER                       79050000
         DD    0,M(10)             F0 = F0/A(I,I)                       79200000
         STD   0,M(4)              Y(I) = F0                            79350000
         SR    2,8                 DECREMENT ROW POINTER                79500000
         AR    4,3                                                      79650000
         QUEND                                                          79800000
         BXH   1,3,MD25            DECR COL POINTER AND LOOP            79950000
*                                                                       80100000
*        RESCALE AND UNDO INTERCHANGES                                  80250000
         L     1,PPBASE                                                 80400000
         L     5,N8                                                     80550000
         SR    5,6                                                      80700000
         SRL   5,1                                                      80850000
         AR    5,1                 R5 IS LIMIT FOR POINTER TO PP        81000000
         L     7,YBASE             BASE FOR Y                           81150000
         LA    4,4                 R4 NOW INCR FOR PP POINTER           81300000
MD30     L     10,M(1)             J = 8*PP(I)                          81450000
         LR    3,10                                                     81600000
         A     3,FACTBASE          POINTER TO FACTOR(J)                 81750000
         MH    10,NP8+2            CHANGE R10 TO ROW POINTER            81900000
         SRL   10,3                DIVIDE OUT EXTRA FACTOR OF 8         82050000
         A     10,ABDATA                                                82200000
         AR    10,0                                                     82350000
         LD    0,M(7)              F0 = Y(I)                            82500000
         DD    0,M(3)              F0 = F0/FACTOR(J)                    82650000
         STD   0,M(10)             A(J,N+L) = F0                        82800000
         AR    7,6                                                      82950000
         BXLE  1,4,MD30            INCR I AND LOOP                      83100000
         AR    0,6                                                      83250000
         C     0,NP8                                                    83400000
         BL    NEXTL               LOOP FOR NEXT RIGHT HAND SIDE        83550000
*                                                                       83700000
*        MOVE RESULT TO FRONT OF M-ENTRY                                83850000
         L     10,RBASE                                                 84000000
         LA    10,12(10)                                                84150000
         A     10,RRANK            R10 POINTS TO FIRST WORD OF RESULT   84300000
         L     5,ABDATA                                                 84450000
         L     6,NP8                                                    84600000
         LR    7,6                                                      84750000
         MH    7,N+2                                                    84900000
         AR    7,5                 R7 IS ROW LIMIT                      85050000
         A     5,N8                                                     85200000
MOVEOVER L     2,P8                                                     85350000
         LR    3,5                                                      85500000
         AR    3,MR                ABS POINTER TO ROW OF B PART         85650000
         LR    4,10                                                     85800000
         AR    4,MR                ABS POINTER TO ROW OF RESULT         85950000
         BAL   LKR,MVCLOOP         MOVE ONE ROW                         86100000
         A     10,P8                                                    86250000
         BXLE  5,6,MOVEOVER        ROW LOOP                             86400000
*                                                                       86550000
*        FINISH RESULT SETUP AND RESET MX                               86700000
CLEANUP  ST    10,MX               CUT BACK MX TO END OF RESULT         86850000
         L     6,RBASE                                                  87000000
         LR    1,10                                                     87150000
         SR    1,6                                                      87300000
         ST    1,M+4(6)            STORE BYTE COUNT FOR RESULT M-ENTRY  87450000
         L     3,RRANK                                                  87600000
         ST    3,M+8(6)            STORE RESULT RANK                    87750000
         LA    3,3                                                      87900000
         STC   3,MTYPE(6)          STORE RESULT TYPE  -  FLOATING       88050000
         L     LKR,MDLKR                                                88200000
         BR    LKR                 RETURN                               88350000
*                                                                       88500000
*        GENERAL MVC LOOP                                               88650000
*        R2 = LENGTH OF MOVE                                            88800000
*        R3 = SOURCE OF MOVE (ABSOLUTE)                                 88950000
*        R4 = SINK OF MOVE (ABSOLUTE)                                   89100000
*        R0,R1,R5 = CONTROL FOR LOOP                                    89250000
*        R0-R5 ARE DESTRYED BY THIS SUBROUTINE                          89400000
MVCLOOP  LA    0,256                                                    89550000
         S     2,MD257                                                  89700000
         LA    1,0(4,2)            UPPER LIMIT FOR MVC LOOP             89850000
         BM    EXFINM              DO WITH SHORT MOVE                   90000000
MOVEIT   MVC   0(256,4),0(3)       DO A LONG MOVE                       90150000
         AR    3,0                 INCREMENT SOURCE                     90300000
         BXLE  4,0,MOVEIT          INCREMENT SINK                       90450000
EXFINM   EX    2,MDMVC             FINISH WITH SHORT MOVE               90600000
         BR    LKR                 RETURN                               90750000
MDMVC    MVC   0(0,4),0(3)         MOVE INDEXED BY R2                   90900000
*                                                                       91050000
*        ERROR ROUTINES                                                 91200000
LENERR   LA    1,ELENGTH                                                91350000
         B     ERRXIT                                                   91500000
RANKERR  LA    1,ERANK                                                  91650000
         B     ERRXIT                                                   91800000
INDXERR  LA    1,EINDEX                                                 91950000
         B     ERRXIT                                                   92100000
RNGERR   LA    1,ERANGE                                                 92250000
ERRXIT   ICALL ERROR                                                    92400000
*                                                                       92550000
*        CONSTANTS                                                      92700000
MD257    DC    F'257'                                                   92850000
ALLBUT7  DC    X'FFFFFFF8'                                              93000000
DONE     DC    D'1.0'                                                   93150000
EPSILON  DC    X'3410000000000000'     16 ** -13                        93300000
CPUTFUZZ DC    D'0.0'              FOR SINGULARITY CHECKING        3070 93450000
*                                                                       93600000
         LTORG                                                          93750000
OPSECT   DSECT                                                          93900000
         ORG   FACTSAVE                                                 94050000
MDLKR    DS    F                                                        94200000
MM       DS    F                                                        94350000
PPP      DS    F                                                        94500000
N        DS    F                                                        94650000
P8       DS    F                                                        94800000
N8       DS    F                                                        94950000
NP8      DS    F                                                        95100000
MNP8     DS    F                                                        95250000
MDPI     DS    F                                                        95400000
ABDATA   DS    F                                                        95550000
YBASE    DS    F                                                        95700000
PPBASE   DS    F                                                        95850000
FACTBASE DS    F                                                        96000000
DYDFLAG  DS    F                                                        96150000
MAXNORM  DS    D                                                        96300000
AKK      DS    D                                                        96450000
SIGMA    DS    D                                                        96600000
ALFA     DS    D                                                        96750000
MDTEMP   DS    4D                                                       96900000
LEND     EQU   *                                                        97050000
         END                                                            97200000
./  ADD    NAME=APLSMFT1
MFT1     TITLE 'APL 360-OS MFT   R E S I D E N T  S V C S'              01330000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02660000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03990000
         SPACE 3                                                        05320000
IGCINIT  CSECT                                                          06650000
CVTDCB   EQU   X'74'                                                    07980000
CVTBTERM EQU   X'34'                                                    09310000
TCBUSER  EQU   X'A8'                                                    10640000
TCBOTC   EQU   X'84'                                                    11970000
TCBFTJST EQU   X'2C'                                                    13300000
SVCOPSW  EQU   X'20'                                                    14630000
SVCNPSW  EQU   X'60'                                                    15960000
DCBDEBAD EQU   44                                                       17290000
DEBDVMOD EQU   32                                                       18620000
DEBDCBAD EQU   24                                                       19950000
         SPACE 3                                                        21280000
         BALR  9,0                                                      22610000
         USING *,9                                                      23940000
         CLI   CVTDCB(3),X'20'     IS THIS MFT?                         25270000
         BNE   IGCFAIL             KILL IT HERE.                        26600000
         LTR   2,0                                                      27930000
         BNZ   IGCFMSK                                                  29260000
         L     5,SAVP44                                                 30590000
         L     6,8(1)                                                   31920000
         CLC   0(4,5),0(6)                                              33250000
         BNE   IGCFAIL                                                  34580000
IGCST    ST    1,TCBUSER(4)                                             35910000
         L     5,TCBOTC(4)                                              37240000
         C     5,TCBFTJST(4)                                            38570000
         BNE   IGCFAIL APL HAS A TWO TASK STRUCTURE                     39900000
         ST    1,TCBUSER(5)                                             41230000
         BR    14                                                       42560000
IGCFMSK  X     0,DEBDCBAD(1)                                            43890000
         N     0,=A(X'FFFFFF')                                          45220000
         BNZ   IGCFAIL                                                  46550000
         LR    0,1                                                      47880000
         X     0,DCBDEBAD(2)                                            49210000
         N     0,=A(X'FFFFFF')                                          50540000
         BNZ   IGCFAIL                                                  51870000
         MVI   DEBDVMOD(1),0                                            53200000
         BR    14                                                       54530000
         DROP  9                                                        55860000
         SPACE 3                                                        57190000
         DC    0D'0'          DOUBLE WORD ALIGNMENT NEEDED FOR MFT      58520000
         ENTRY IGCMAP                                                   59850000
IGCMAP   BALR  9,0                                                      61180000
         USING *,9                                                      62510000
         L     5,SAVP44                                                 63840000
         L     2,TCBUSER(4)                                             65170000
         LM    6,8,0(2)                                                 66500000
         CLC   0(4,5),0(8)                                              67830000
         BNE   IGCFAIL                                                  69160000
         MVC   0(8,6),SVCOPSW                                           70490000
         ST    7,SVCOPSW+4                                              71820000
         NC    SVCOPSW(4),SVCNPSW                                       73150000
         BR    14                                                       74480000
         DROP 9                                                         75810000
         SPACE 3                                                        77140000
*                                                                       78470000
*  THIS IS AN INVALID CALL TO THE APL SVC'S                             79800000
*        THE CALLING TASK WILL BE TERMINATED                            81130000
*          WITH A S-FXX ABEND, WHERE XX IS THE SVC NUMBER               82460000
*                                                                       83790000
IGCFAIL  LR    0,4       ADDRESS OF TCB TO BE TERMINATED                85120000
         LA    1,X'F00'                                                 86450000
         IC    1,SVCOPSW+3    GET SVC CODE                              87780000
         SLL   1,12                                                     89110000
         L     15,CVTBTERM(3)                                           90440000
         BR    15                                                       91770000
         SPACE 3                                                        93100000
         EXTRN SVCSAV                                                   94430000
SAVP44   DC    A(SVCSAV+44)                                             95760000
         LTORG                                                          97090000
         END                                                            98420000
./  ADD    NAME=APLSMIBM
MIBM     TITLE 'MONADIC I-BEAM -- MOSTLY NONPRIV SYSTEM INFO  05/11/70' 00270000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00540000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00810000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01080000
EXMHIST  CSECT                                                          01350000
         EXTRN ERROR                                                    01890000
         EXTRN FETCHINT                                                 02160000
         EXTRN GCOL                                                     02430000
         EXTRN GETIME                                                   02700000
         EXTRN HDIR                                                     02970000
         EXTRN IODCON                                                   03240000
         EXTRN OPSPACE                                                  03510000
         EXTRN SUPPARS             MAPPED BY SUPPARD DSECT         2230 03780000
         PRINT OFF   APLDEFN, ZSYMBOLS, OPSECT, PERTERM, APLSUPC   2230 04050000
         APLSUPC ,                 MAPS SUPPARS AREA IN APLSUP     2230 04320000
VALCON   EQU   0                   AVOIDS ASM ERROR                2230 04590000
         COPY  APLDEFN                                                  04860000
         COPY  ZSYMBOLS                                                 05130000
         COPY  OPSECT                                                   05400000
         COPY PERTERM                                                   05670000
         TITLE 'MONADIC I-BEAM -- MOSTLY NONPRIV SYSTEM INFO  05/11/70' 05940000
         PRINT ON,NOGEN                                                 06210000
*                                                                       06480000
*        IBEAM OPERANDS                                                 06750000
*                                                                       07020000
*        0-18  HISTOGRAMS                                               07290000
*        19    CUMULATIVE KEYING TIME IN 60THS                          07560000
*        20    TIME OF DAY IN 60THS OF SECONDS.                         07830000
*        21    COMPUTE TIME SINCE SIGNON IN 60THS.                      08100000
*        22    STORAGE REMAINING (MINGL+SVI-MX).                        08370000
*        23    NUMBER OF USERS SIGNED ON.                               08640000
*        24    USER'S SIGN ON TIME.                                     08910000
*        25    DATE.                                                    09180000
*        26    CURRENT VALUE OF LINE COUNTER.                           09450000
*        27    LINE COUNTER STACK.                                      09720000
*        28    TERMINAL TYPE CODE                                       09990000
*        29    USER ACCOUNT NUMBER                                      10260000
*                                                                       10530000
*        99    FETCH I/O DEBUG TRACE TABLE                              10800000
*                                                                       11070000
         SPACE                                                          11340000
EXMHIST  CSECT                                                          11610000
         USING *,9                                                      11880000
         USING OPSECT-16,LR                                             12150000
         ST    LKR,TEMPRES         SAVE LINK.                           12420000
         SPACE                                                          12690000
         L     2,RHXRHO            MAKE SURE RH OPERAND IS 1 ELEMENT.   12960000
         BCT   2,RANKERR           IF NOT 1 ELEMENT, RANK ERROR         13230000
*                                  R2 = 0 NOW FOR FETCHINT (ARG 1)      13500000
         L     4,RHBASE            OTHERWISE, FETCH IT.                 13770000
         A     4,RHRANK                                                 14040000
         LA    4,MRHO-M(4)                                              14310000
         L     3,RHTYPE                                                 14580000
         ICALL FETCHINT            NOW HAVE IT IN R0.                   14850000
         SPACE                                                          15120000
         LTR   8,0                 TEST FOR NEGATIVE.                   15390000
         BM    RNGERR              BRANCH IF SO.                        15660000
         C     8,HST19             SEE IF HISTOGRAMS ARE DESIRED        15930000
         BL    IBHIST              IF SO, GO DO IT                      16200000
         C     8,HST99             SEE IF SYSTEM PROGRAMMER INFORMATION 16470000
*                                  IS DESIRED.                          16740000
         BE    CEIODBUG            YES, I/O TRACE                       17010000
*        DROP THRU TO USER INFORMATION IBEAMS                           17280000
         EJECT                                                          17550000
*                                                                       17820000
*        MISCELLANEOUS INFORMATION -- IBEAM 19 THRU 29                  18090000
*                                                                       18360000
         S     8,HST19             GET DOWN INTO RANGE                  18630000
         SLL   8,2                 MULTIPLY OPERAND BY 4.               18900000
         C     8,IBEND             SEE IF IT EXISTS.                    19170000
         BNL   RNGERR              BRANCH IF NOT.                       19440000
         L     5,IBTAB(8)          PICK UP ROUTINE ADDRESS              19710000
         AR    8,9                 CONVERT INDEX TO ABS ADDR            20250000
         TM    IBTAB-EXMHIST(8),VECTRSLT  IF VECT RESULT, DON'T GET     20520000
         BCR   1,5 BOR             SPACE FOR SCALER, LET HIM GET SPACE. 20790000
*                                                                       21060000
*        GETSPACE FOR SCALAR INTEGER RESULT.                            21330000
*                                                                       21600000
         LA    1,1                 NEED SPACE FOR 1 ELEMENT.            21870000
         SR    2,2                 SCALAR.                              22140000
         LA    3,2                 INTEGER.                             22410000
         L     10,=A(OPSPACE)      GET ENTRY TO COMMON GETSPACE.        22680000
         BALR  LKR,10              AND CALL IT.                         22950000
         SPACE                                                          23220000
         ST    1,RBASE             SAVE THE M-POINTER.                  23490000
         L     2,TPRANK0                                                23760000
         ST    2,MTYPE(1)          INTEGER TYPE, SCALAR RANK            24300000
         LA    7,MRHO-M(1)         POINTER TO RESULT ELEMENT.           24570000
         ST    7,RESORG                                                 24840000
         L     4,MPTBASE           LOAD PERTERM BASE IN CASE NEEDED     25110000
         BR    5                   JUMP INTO APPROPRIATE ROUTINE        25380000
         EJECT                                                          25650000
*                                                                       25920000
*        CUMULATIVE KEYING TIME IN 60THS                                26190000
*                                                                       26460000
IBKTIME  L     1,PTMTIM3-PERTERM(4)                                     26730000
IBTCOM   A     1,HST3              ROUND UP TIME                        27000000
         SR    0,0                 CLEAR HIGH REGISTER                  27270000
         D     0,HST5              CONVERT TO 60THS                     27540000
IBXIT    ST    1,M(7)              STORE RESULT                         27810000
         L     LKR,TEMPRES         AND RETURN.                          28080000
         BR    LKR                                                      28350000
         SPACE 2                                                        28620000
*                                                                       28890000
*        TIME OF DAY IN 60THS OF SECONDS.                               29160000
*                                                                       29430000
IBTOD    ICALL GETIME              GET TIME OF DAY IN TIMER UNITS (R1)  29700000
         B     IBTCOM                                                   29970000
         SPACE 2                                                        30240000
*                                                                       30510000
*        COMPUTE TIME SINCE SIGNON IN 60THS OF SECONDS.                 30780000
*                                                                       31050000
IBCT     SVCC  YYQZ                FORCE APLSUP TO UPDATE CPU TIME      31320000
         L     1,PTICTME-PERTERM(4)  COMPUTE TIME THIS INTERVAL         31590000
         A     1,PTABTM-PERTERM(4)   ADD ACTUAL BILLING TIME            31860000
         B     IBTCOM                                                   32130000
         SPACE 2                                                        32400000
*                                                                       32670000
*        UNUSED STORAGE IN BYTES.                                       32940000
*                                                                       33210000
IBSTRG   L     1,SVI               BOTTOM OF STAC2.                     33480000
         S     1,MX                TOP OF M-ENTRIES.                    33750000
         A     1,MINGL             UNCOLLECTED GARBAGE.                 34020000
         B     IBXIT                                                    34290000
         SPACE 2                                                        34560000
*                                                                       34830000
*        NUMBER OF USERS SIGNED ON.                                     35100000
*                                                                       35370000
IBUSERS  L     4,=A(SUPPARS)                                       2230 35640000
         LM    4,6,PTBXLE-SUPPARD(4)                               2230 35910000
         USING PERTERM,6                                                36180000
         SR    1,1                 INITIALIZE RESULT                    36450000
         B     LPEND               DON'T COUNT OPERATOR.                36720000
ALOOP    TM    IOB1,NSIGNM         TEST FOR SIGN ON.                    36990000
         BO    LPEND               BRANCH IF NOT.                       37260000
         LA    1,1(1)              OTHERWISE, INCREMENT COUNT           37530000
LPEND    BXLE  6,4,ALOOP           LOOP.                                37800000
         DROP  6                                                        38070000
         B     IBXIT                                                    38340000
         SPACE 2                                                        38610000
*                                                                       38880000
*        SIGN ON TIME.                                                  39150000
*                                                                       39420000
IBSOT    L     1,PTSOTM-PERTERM(4) PICK UP SIGN ON TIME                 39690000
         B     IBTCOM                                                   39960000
         SPACE 2                                                        40230000
*                                                                       40500000
*        PRESENT DATE.                                                  40770000
*                                                                       41040000
IBDATE   L     1,=V(ZSYMDATE)      GET POINTER TO DATE IN ZSYMBOLS.     41310000
         MVC   DBLSAVE(6),COMPTR   MOVE IN A COMPRESSION TANLE,         41580000
         TR    DBLSAVE(6),0(1)     COMPRESS OUT SLASHES.                41850000
         TR    DBLSAVE(6),TRDAT                                         42120000
         PACK  DBLHOLD(8),DBLSAVE(6)                                    42390000
         CVB   1,DBLHOLD           CONVERT TO BINARY INTEGER            42660000
         B     IBXIT                                                    42930000
         SPACE 2                                                        43200000
*                                                                       43470000
*        CURRENT VALUE OF LINE COUNTER.                                 43740000
*                                                                       44010000
IBSTAR   L     3,PARREL            GO THROUGH PARREL,                   44280000
         LH    1,STLINE(MR,3)      TO PICK UP CURRENT LINE COUNTER.     44550000
         B     IBXIT                                                    44820000
         SPACE 2                                                        45090000
*                                                                       45360000
*        LINE POINTER STACK.                                            45630000
*                                                                       45900000
*        RUN BACK THROUGH STFREG, GETTING STLINE AT EACH LEVEL.         46170000
*                                                                       46440000
IBLSTACK SR    6,6                 FIRST WE COUNT THE ENTRIES           46710000
         L     3,PARREL                                                 46980000
IBLSTK1  L     3,STFREG(MR,3)      STFREG POINTS TO NEXT ENTRY          47250000
         LTR   3,3                                                      47520000
         BZ    IBLSTK3             IF ZERO, NO MORE                     47790000
         LA    6,4(6)              INCRIMENT BYTE COUNT                 48060000
         B     IBLSTK1                                                  48330000
IBLSTK3  BAL   8,GETVECT           GET SPACE FOR VECTOR RESULT          48600000
         L     3,PARREL                                                 48870000
IBLSTK5  LH    2,STLINE(MR,3)      PICK UP LINE NUMBER                  49140000
         L     3,STFREG(MR,3)      STFREG POINTS TO NEXT ENTRY          49410000
         LTR   3,3                                                      49680000
         BCR   8,LKR BZR           ZERO MEANS WE'RE DONE                49950000
         ST    2,0(7)              SAVE RESULT                          50220000
         LA    7,4(7)              POINT TO NEXT RESULT                 50490000
         B     IBLSTK5                                                  50760000
*                                                                       51030000
*                                                                       51300000
*                                                                       51570000
*        TERMINAL TYPE CODE                                             51840000
*                                                                       52110000
*              1 = 2741  2 = TS41  3 = 1050  4 = 1052-7                 52380000
*                                                                       52650000
IBTTYPE  SR    1,1                 PICK UP PTTYPE CODE                  52920000
         IC    1,PTTYPE-PERTERM(4)                                      53190000
         LA    1,PERDEVXL-4(1)     SCALE FOR ORIGIN-1 INDEXING          53460000
         SR    0,0                                                      53730000
         D     0,=A(PERDEVXL)                                           54000000
         IC    1,IBTTTAB-1(1)      CONVERT TO OUR CODE NUMBER           54270000
         B     IBXIT                                                    54540000
*                                                                       54810000
*                                                                       55080000
*                                                                       55350000
*        USER ACCOUNT NUMBER                                            55620000
*                                                                       55890000
IBMANNO  L     1,PTMAN-PERTERM(4)                                       56160000
         B     IBXIT                                                    56430000
*                                                                       56700000
*                                                                       56970000
*                                                                       57240000
*                                                                       57510000
*        OBTAIN HISTOGRAMS FROM APLSUP                                  57780000
*                                                                       58050000
IBHIST   BAL   7,PRIVTEST          USER MUST BE PRIVILEGED.             58320000
         SLL   8,3                 MULTIPLY BY 8                        58590000
         L     4,=A(HDIR)          POINT TO HISTOGRAM DIRECTORY         58860000
         C     8,0(4)              IS HISTOGRAM DEFINED                 59130000
         BNL   RNGERR              NOPE, ERROR                          59400000
         AR    8,4                                                      59670000
         LM    5,6,4(8)            LOAD ADDRESS, COUNT                  59940000
         CR    5,4                 IF ADDR LT HDIR, HISTOGRAM TABLES    60210000
         BL    RNGERR              APPEAR TO HAVE BEEN OMITTED.         60480000
         BAL   8,GETVECT           RESERVE SPACE FOR VECTOR RESULT      60750000
         BAL   8,MOVER             BLAST IN INFORMATION                 61020000
         BR    LKR                 RETURN                               61290000
*                                                                       61560000
*                                                                       61830000
*                                                                       62100000
*        CEIODBUG FETCHES THE IODBUGG TABLE FROM APLSUP.                62370000
*                                                                       62640000
*        THE I/O TRACE TABLE (IODBUGG) IS A REVOLVING TRACE TABLE       62910000
*        WHICH RECORDS ALL I/O INTERRUPTS & ALL SIO DONE BY APLSUP,     63180000
*        FOR ANALYSIS IN SYSTEM & HARDWARE DEBUGGING.                   63450000
*                                                                       63720000
*        IODBUGG MUST BE FETCHED WITH ALL INTERRUPTS DISABLED TO        63990000
*        GUARANTEE THE RELIABILITY OF THE RESULT.  SVRAPE PUTS US       64260000
*        IN SUPERVISOR STATE, PROTECT KEY = 0, ALL INTERRUPTS DISABLED  64530000
*        (WE REALLY DON'T NEED SUPVR STATE OR KEY=0), THEREFORE WE      64800000
*        MUST BE DAMN CAREFUL IN THE FOLLOWING ROUTINE.  NOTE THAT      65070000
*        SVRAPE RESERVES THE USE OF R2 & R14 FOR ITS OWN USE.           65340000
*                                                                       65610000
*        THE RESULT IS A VECTOR OF ENTRIES ORDERED FROM LEAST TO        65880000
*        MOST RECENT.  SEE THE IODBUG DSECT IN APLSUP FOR THE           66150000
*        FORMAT & LENGTH OF EACH ENTRY.                                 66420000
*                                                                       66690000
CEIODBUG BAL   7,PRIVTEST          USER MUST BE PRIV TO ENTER THESE     66960000
         L     4,=A(IODCON)          MOST SACRED GROUNDS.               67230000
         LM    5,6,4(4)            LOAD START,END                       67500000
         SR    6,5                 COMPUTE TOTAL LENGTH OF RESULT       67770000
         BAL   8,GETVECT           GET SPACE FOR VECTOR RESULT          68040000
         SVRAPE ,                  REQUEST ANAMOLOUS PROTECTION EXCEP   68310000
         BAL   1,IODBRAPE          LINK TO ROUTINE TO DO THE WORK       68580000
         BR    LKR                 RETURN                               68850000
*                                                                       69120000
IODBRAPE LM    4,6,0(4)            PICK UP INDEX, START, END            69390000
         SR    6,4                 R6 = LENGTH (END-INDEX)              69660000
         LR    3,5                 SAVE  START  OVER MOVER              69930000
         LR    5,4                 R5 = START (INDEX)                   70200000
         BAL   8,MOVER             MOVE PART 1                          70470000
         LR    5,3                 R5 = START (START)                   70740000
         LR    6,4                                                      71010000
         SR    6,3                 R6 = LENGTH (INDEX-START)            71280000
         BAL   8,MOVER             MOVE PART 2                          71550000
         BR    1                   EXIT BACK TO SVRAPE IN APLSUP        71820000
*                                                                       72090000
*                                                                       72360000
*        GETVECT RESERVES SPACE FOR INTEGER VECTOR                      72630000
*              R6 = BYTE COUNT (ACTUAL)     R8 = LINK REGISTER          72900000
*              R7 = RETURNS ADDRESS         R15 = RESTORED FROM TEMPRES 73170000
*              R0 R1 R2 R3 R10 = SCRATCHED                              73440000
*                                                                       73710000
GETVECT  LR    1,6                 PICK UP LENGTH IN BYTES              73980000
         LA    2,4                 RESULT WILL BE VECTOR                74250000
         LR    3,2                 CHAR TYPE SAVES US A LITTLE WORK     74520000
         L     10,=A(OPSPACE)                                           74790000
         BALR  LKR,10              OPSPACE REALLY GETS US THE SPACE     75060000
         L     2,TPRANK            BUILD RESULT OVERHEAD AS INTEGER     75600000
         ST    2,MTYPE(1)            VECTOR.                            75870000
         LA    2,3(6)              HE SHOULD (BUT MIGHT NOT) BE ON  A   76140000
         SRL   2,2                   WORD MULTIPLE.                     76410000
         ST    2,MRHO(1)           NUMBER OF ELEMENTS IN VECTOR         76680000
         LA    7,MRHO+4(1)                                              76950000
         ST    7,RESORG            ABSOLUTE RESULT POINTER              77220000
         L     LKR,TEMPRES                                              77490000
         BR    8                                                        77760000
*                                                                       78030000
*                                                                       78300000
*                                                                       78570000
*        MOVER BLASTS AN AREA OF CORE TO THE RESULT                     78840000
*              R0 = SCRATCH (256)           R5 = FROM ADDRESS           79110000
*              R6 = COUNT (ACTUAL)          R7 = TO ADDRESS             79380000
*              R8 = LINK REGISTER                                       79650000
*              ON EXIT R7 IN UPDATED                                    79920000
*                                                                       80190000
MOVER    LA    0,256               INITIALIZE                           80460000
         BCTR  6,0                 CONVERT TO SS COUNT                  80730000
MOVEX    CR    6,0                 IS COUNT LESS THAN 256               81000000
         BL    MOVEZ               YES, MOVE RESIDUE (IF ANY)           81270000
         MVC   0(256,7),0(5)       MOVE 256 BYTES                       81540000
         SR    6,0                 DECREMENT COUNT BY 256               81810000
         AR    5,0                 INCREMENT FROM ADDR BY 256           82080000
         AR    7,0                 INCREMENT TO ADDR BY 256             82350000
         B     MOVEX               LOOP BACK FOR MORE                   82620000
*                                                                       82890000
MOVEZ    LTR   6,6                 EVERYTHING MOVED                     83160000
         BCR   4,8 BL              YES, RETURN                          83430000
         EX    6,MOVESOME          NOT QUITE DONE, MOVE RESIDUE         83700000
         LA    7,1(6,7)            INCREMENT  TO ADDR  BY RESIDUE       83970000
         BR    8                   DONE, RETURN                         84240000
         SPACE 3                                                        84510000
*        PRIVTEST REJECTS WITH ERROR ANY USER NOT PRIVILEGED.           84780000
*                                                                       85050000
PRIVTEST L     2,=A(SUPPARS)       ADDR OF SUPERVISOR PARMS        2230 85320000
         L     2,PTBASE-SUPPARD(2) ADDR OF PERTERM FOR CURR USER   2230 85590000
         USING PERTERM,2                                                85860000
         TM    IOB1,PRIVBIT        DOES HE HAVE FULL PRIV               86130000
         BCR   1,7 BOR             YES, HE'S OK                         86400000
*                                  NOPE, FALL THRU TO ERROR MESSAGE     86670000
*                                                                       86940000
*                                                                       87210000
RNGERR   LA    1,ERANGE            RANGE ERROR (DOMAIN ERROR) REPORT    87480000
         B     ERRORXIT                                                 87750000
*                                                                       88020000
RANKERR  LA    1,ERANK             RANK ERROR REPORT                    88290000
ERRORXIT ICALL ERROR                                                    88560000
         EJECT                                                          88830000
*                                                                       89100000
*        CONSTANTS AND LIKE THAT.                                       89370000
*                                                                       89640000
         SPACE                                                          89910000
MOVESOME MVC   0(0,7),0(5)                                              90180000
         SPACE                                                          90450000
HST3     DC    F'3'                                                     90720000
HST5     DC    F'5'                                                     90990000
HST19    DC    F'19'                                                    91260000
HST99    DC    F'99'                                                    91530000
*                                                                       91800000
VECTRSLT EQU   X'01'                                                    92070000
IBEND    DC    A(IBTEND-IBTAB)                                          92340000
IBTAB    EQU   *                   ORDER IS IMPORTANT.                  92610000
         DC    A(IBKTIME)          19                                   92880000
         DC    A(IBTOD)            20                                   93150000
         DC    A(IBCT)             21                                   93420000
         DC    A(IBSTRG)           22                                   93690000
         DC    A(IBUSERS)          23                                   93960000
         DC    A(IBSOT)            24                                   94230000
         DC    A(IBDATE)           25                                   94500000
         DC    A(IBSTAR)           26                                   94770000
         DC    AL1(VECTRSLT)       27                                   95040000
         DC    AL3(IBLSTACK)       27                                   95310000
         DC    A(IBTTYPE)          28                                   95580000
         DC    A(IBMANNO)          29                                   95850000
IBTEND   EQU   *                                                        96120000
         SPACE                                                          96390000
FRACMASK DC    X'00FFFFFF'                                              96660000
TPRANK0  DC    X'02000000'                                              96930000
TPRANK   DC    X'02000004'                                              97200000
IBTTTAB  DC    AL1(2,1,0,3,4)      TS41,2741,AMBIG,1050,1052            97470000
PERDEVXL EQU   X'14'               LENGTH OF PERDEVXG ENTRY             97740000
COMPTR   DC    X'000103040607'                                          98010000
TRDAT    EQU   *-Z0                                                     98280000
         DC    C'0123456789'                                            98550000
*                                                                       98820000
         LTORG                                                          99090000
         END                                                            99360000
./  ADD    NAME=APLSMRIO
MRIO     TITLE 'M O N A D I C   R H O   A N D   I O T A       05/11/70' 00980000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01960000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02940000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03920000
         PRINT OFF       APLDEFN, OPSECT                                05880000
EXMIOTA  CSECT                                                          06860000
         COPY  APLDEFN                                                  07840000
         COPY  OPSECT                                                   08820000
         PRINT ON,NOGEN                                                 09800000
         TITLE 'M O N A D I C   R H O   A N D   I O T A       05/11/70' 10780000
         EXTRN OPSPACE                                                  11760000
         EXTRN FETCH                                                    12740000
         EXTRN ERROR                                                    13720000
EXMIOTA  CSECT                   , INTERVAL VECTOR GENERATOR            14700000
         USING *,9                                                      15680000
         USING OPSECT-16,LR                                             16660000
         ST    LKR,DBLSAVE         SAVE LINK.                           17640000
         L     1,RHXRHO           WE'RE GETTING SPACE.                  18620000
         C     1,OC1              OPERAND MUST HAVE 1 ELEMENT.          19600000
         LA    1,ERANK                                                  20580000
         BNE   RANKEROR           TOO BAD.                              21560000
         L     4,RHBASE           GET BASE.                             22540000
         LA    4,MRHO-M(4)        ADD IN HEAD LENGTH.                   23520000
         A     4,RHRANK           AND RANK.                             24500000
         L     3,RCTYPE           PICK UP CONVERSION TYPE.              25480000
         SR    2,2                WANT FIRST ELEMENT.                   26460000
         ICALL FETCH              SO FETCH IT.                          27440000
         LTR   0,0                                                      28420000
         BNL   GIVEM               TEST FOR NEGATIVE.                   29400000
         LA    1,ERANGE            IF TRUE, DOMAIN ERROR                30380000
RANKEROR EQU   *                                                        31360000
         ICALL ERROR                                                    32340000
GIVEM    EQU   *                                                        33320000
         ST    0,LHXRHO           AND SAVE IT.                          34300000
         LR    1,0                 MOVE TO R1.                          35280000
         LA    2,4                 RANK IS VECTOR.                      36260000
         LA    3,2                 TYPE IS INTEGER.                     37240000
         L     10,=A(OPSPACE)      GET ENTRY INTO COMMON GETSPACE.      38220000
         BALR  LKR,10              AND ENTER IT.                        39200000
         LA    7,MRHO(1)           ABSOLUTE PTR TO RESULT.              40180000
         L     6,LHXRHO           PICK UP OUR COUNT.                    41160000
         ST    6,MRHO(1)                                                42140000
         LTR   6,6                                                      43120000
         BNH   HEDEM              IF ZERO OR NEG, EMPTY VECTOR.         44100000
IOTEM    LR    5,6                                                      45080000
         SLL   5,2                                                      46060000
         LR    8,6                 MOVE VALUE OVER.                     47040000
         BCTR  8,0                 DECREMENT IT BY 1.                   48020000
         A     8,IORIGIN           ADD INDEX ORIGIN.                    49000000
         ST    8,0(7,5)            STORE RESULT.                        49980000
         BCT   6,IOTEM                                                  50960000
HEDEM    EQU   *                                                        51940000
         L     6,TWO4              INTEGER TYPE, RANK 4.                53900000
         ST    6,MTYPE(1)                                               55860000
         L     LKR,DBLSAVE         PICK UP LINK.                        56840000
         BR    LKR                 AND RETURN.                          57820000
*                                                                       58800000
OC1      DC    F'1'                                                     59780000
TWO4     DC    X'02000004'                                              60760000
         EJECT                                                          61740000
*                                                                       62720000
*        MONADIC RHO - RANK VECTOR.                                     63700000
*                                                                       64680000
EXMRHO   EQU   *                                                        65660000
         ENTRY EXMRHO                                                   66640000
         USING *,9                                                      67620000
         USING OPSECT-16,LR                                             68600000
         ST    LKR,DBLSAVE         SAVE LINK.                           69580000
         L     1,RHRANK            PICK UP OPERAND RANK.                70560000
         SRL   1,2                 DIVIDE BY 4 TO GET ELEMENTS.         71540000
         LA    2,4                 RANK IS VECTOR.                      72520000
         LA    3,2                 TYPE IS INTEGER.                     73500000
         L     10,=A(OPSPACE)      PICK UP ENTRY TO COMMON GETSPACE.    74480000
         BALR  LKR,10              AND ENTER IT.                        75460000
         LR    7,1                                                      76440000
         L     6,TOO4             RANK AND TYPE.                        77420000
         ST    6,MTYPE(7)         AND PUT THEM IN.                      79380000
         L     6,RHRANK           PICK UP OPERAND RANK AGAIN.           80360000
         LR    4,6                 SAVE THIS.                           81340000
         SRA   6,2                 DIVIDE BY 4.                         82320000
         ST    6,MRHO(7)          INTO FIRST DIMENSION.                 83300000
         BZ    DUNIT                                                    84280000
         L     5,RHBASE            PICK UP RH M-POINTER.                85260000
         LA    5,MRHO(5)          ABSOLUTE POINTER.                     86240000
         LA    7,MRHO+4(7)         ABSOLUTE PTR TO RESULT.              87220000
         BCTR  4,0                 TAKE ACRE OF OFFSET.                 88200000
         EX    4,MOVEMIN           MOVE IN RANK VECTOR.                 89180000
DUNIT    L     LKR,DBLSAVE         PICK UP LINK.                        90160000
         BR    LKR                 AND RETURN.                          91140000
*                                                                       92120000
MOVEMIN  MVC   0(0,7),0(5)         MOVER.                               93100000
         DC    0F'0'                                                    94080000
TOO4     DC    X'02000004'                                              95060000
         EJECT                                                          96040000
         LTORG                                                          97020000
         EJECT                                                          98000000
         END                                                            98980000
./  ADD    NAME=APLSMSOP
MSOP     TITLE 'M I S C   M A T H   S C A L A R   O P S       05/11/70' 00060000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00120000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00180000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00240000
         GBLB  &HIPREC             &HIPREC = 1 IF HIGH PRECISION TAN &  00300000
*                                  TANH ROUTINES (WHICH USE MORE CORE)  00360000
*                                  ARE DESIRED.                         00420000
&HIPREC  SETB  (1)                                                      00480000
&HIPREC  SETB  (0)                                                      00540000
         PRINT OFF                 COPY  APLDEFN                        00660000
MSCOPS&HIPREC  CSECT                                                    00720000
         COPY  APLDEFN                                                  00780000
     TITLE 'EXCIRCLE    A P L / 3 6 0    D Y A D I C    C I R C L E'    00840000
         PRINT ON,NOGEN                                                 00900000
MSCOPS&HIPREC  CSECT                                                    00960000
*                                                                       01020000
*              DYADIC  CIRCLE  FUNCTION                                 01080000
*                                                                       01140000
*        CALL  GR1 = LEFT ARGUMENT   (INTEGER)                          01200000
*              FR2 = RIGHT ARGUMENT   (DOUBLE FLOATING)                 01260000
*                                                                       01320000
*        RETN  FR0 = RESULT   (DOUBLE FLOATING)                         01380000
*                                                                       01440000
*                                                                       01500000
         EXTRN ERROR                                                    01560000
         ENTRY EXCIRCLE                                                 01620000
         USING *,9                 PROGRAM BASE                         01680000
         USING LOCAL,TLR           SCRATCH AREA                         01740000
EXCIRCLE ST    LKR,SAVELKR         SAVE LKR IN CASE WE CALL SOMEONE     01800000
         STD   2,BUFF              SAVE ARG FOR POSSIBLE FUTURE TESTS   01860000
         LPDR  2,0                 GET POSITIVE COPY                    01920000
         AD    2,CNVTFUZZ          ADD ABSOLUTE FUZZ                    01980000
         AW    2,DUNZERO           TRUNCATE                             02040000
         STD   2,BUFF2             STORE INTEGER                        02100000
         AD    2,DUNZERO           RENORMALIZE                          02160000
         LPDR  4,0                 GET POSITIVE COPY OF ARG             02220000
         SDR   2,4                 GET REMAINDER                        02280000
         LPER  2,2                                                      02340000
         CD    2,CNVTFUZZ                                               02400000
         BH    RNGERR              DOMAIN ERROR IF LARGER THAN FUZZ     02460000
         L     1,BUFF2+4           GICK UP INTEGER IN R1                02520000
         CD    0,LNV               COMPARE WITH -.69....                02580000
         BH    *+6                 COMPLEMENT IF NECESSARY              02640000
         LCR   1,1                                                      02700000
         LD    2,BUFF              RESTORE RIGHT ARGUMENT               02760000
         LA    1,((CIRCZERO-CIRCLOW)/2)(1)   MAKE ALL VALID ARG +, 0    02820000
         CL    1,=A((CIRCHIGH-CIRCLOW)/2)  IS ARGUMENT WITHIN DOMAIN?   02880000
         BNL   RNGERR              NO, DOMAIN ERROR                     02940000
         AR    1,1                 LOOK UP ROUTINE DISPLACEMENT         03000000
         LH    1,CIRCLOW(1)                                             03060000
         B     EXCIRCLE(1)                                              03120000
*                                                                       03180000
*              DYADIC CIRCLE TRANSFER VECTOR                            03240000
*                                                                       03300000
CIRCLOW  DS    0H                                                       03360000
         DC    AL2(ATANH-EXCIRCLE)   -7  HYPERBOLIC ARC TANGENT         03420000
         DC    AL2(ACOSH-EXCIRCLE)   -6  HYPERBOLIC ARC COSINE          03480000
         DC    AL2(ASINH-EXCIRCLE)   -5  HYPERBOLIC ARC SINE            03540000
         DC    AL2(CIRM4-EXCIRCLE)   -4  ((X**2)-1)**.5                 03600000
         DC    AL2(ATAN-EXCIRCLE)    -3  ARC TANGENT                    03660000
         DC    AL2(ACOS-EXCIRCLE)    -2  ARC COSINE                     03720000
         DC    AL2(ASIN-EXCIRCLE)    -1  ARC SINE                       03780000
CIRCZERO DC    AL2(CIR0-EXCIRCLE)     0  (1-X**2)**.5                   03840000
         DC    AL2(SIN-EXCIRCLE)     +1  SINE                           03900000
         DC    AL2(COS-EXCIRCLE)     +2  COSINE                         03960000
         DC    AL2(TAN-EXCIRCLE)     +3  TANGENT                        04020000
         DC    AL2(CIR4-EXCIRCLE)    +4  ((X**2)+1)**.5                 04080000
         DC    AL2(SINH-EXCIRCLE)    +5  HYPERBOLIC SINE                04140000
         DC    AL2(COSH-EXCIRCLE)    +6  HYPERBOLIC COSINE              04200000
         DC    AL2(TANH-EXCIRCLE)    +7  HYPERBOLIC TANGENT             04260000
CIRCHIGH EQU   *                                                        04320000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -7  O  X'   04380000
*                                                                       04440000
*        HYPERBOLIC ARC TANGENT                                         04500000
*                                                                       04560000
*              -7  CIRCLE  X                                            04620000
*                                                                       04680000
*              1.  IF /X/ GREATER OR = 0.169 USE                        04740000
*                   ATANH(X) = 0.5*LOG((1+X)/(1-X))                     04800000
*              2. OTHERWISE USE                                         04860000
*                   ATANH(X) = ATANH15(X)                               04920000
*                                                                       04980000
ATANH    LPDR  0,2                                                      05040000
         CD    0,ATANHC9                                                05100000
         BNL   ATANHIGH                                                 05160000
         BAL   4,ATANH15                                                05220000
         BR    LKR                                                      05280000
ATANHIGH LD    0,ONE                                                    05340000
         LDR   4,0                                                      05400000
         SDR   4,2                                                      05460000
         ADR   2,0                                                      05520000
         DDR   2,4                                                      05580000
         ICALL EXMLOG,*            COMPUTE LOG                          05640000
         L     LKR,SAVELKR                                              05700000
         HDR   0,0                                                      05760000
         BR    LKR                 RETURN                               05820000
         SPACE 3                                                        05880000
*                                                                       05940000
*        ATANH15(X) = X/1-(X**2)/3-4*(X**2)/5-9*(X**2)/7-16*(X**2)/     06000000
*                   9-25*(X**2)/11-36*(X**2)/13-49*(X**2)/15            06060000
*                                                                       06120000
ATANH15  LDR   6,2                                                      06180000
         MDR   6,6                                                      06240000
         LCDR  0,6                                                      06300000
         MD    0,ATANHC0                                                06360000
         AD    0,ATANHC1                                                06420000
         LCDR  4,6                                                      06480000
         DDR   4,0                                                      06540000
         AD    4,ATANHC2                                                06600000
         LCDR  0,6                                                      06660000
         DDR   0,4                                                      06720000
         AD    0,ATANHC3                                                06780000
         LCDR  4,6                                                      06840000
         DDR   4,0                                                      06900000
         AD    4,ATANHC4                                                06960000
         LCDR  0,6                                                      07020000
         DDR   0,4                                                      07080000
         AD    0,ATANHC5                                                07140000
         LDR   4,6                                                      07200000
         DDR   4,0                                                      07260000
         SD    4,ATANHC6                                                07320000
         DDR   6,4                                                      07380000
         AD    6,ONE                                                    07440000
         DDR   2,6                                                      07500000
         LDR   0,2                                                      07560000
         BR    4                   RETURN                               07620000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -6  O  X'   07680000
*                                                                       07740000
*        HYPERBOLIC ARC COSINE                                          07800000
*                                                                       07860000
*              -6  CIRCLE  X                                            07920000
*                                                                       07980000
*              ACOSH(X) = LOG(X+SQRT(-1+X**2))                          08040000
*                                                                       08100000
ACOSH    LDR   6,2                 FR6 TRANSPARENT TO SQRT              08160000
         MDR   2,2                                                      08220000
         SD    2,ONE                                                    08280000
         BAL   3,SQRT              SQRT (-1+X**2)                       08340000
         LDR   2,6                                                      08400000
         ADR   2,0                                                      08460000
         B     EXMLOG              CALL LOG (WHICH WILL THEN EXIT)      08520000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -5  O  X'   08580000
*                                                                       08640000
*        HYPERBOLIC ARC SINE                                            08700000
*                                                                       08760000
*              -5  CIRCLE  X                                            08820000
*                                                                       08880000
*              1.  IF /X/ GREATER OR = 0.169 USE                        08940000
*                   ASINH(X)  = (LOG(/X/+SQRT(1+X**2))) / X / /X/       09000000
*              2. OTHERWISE USE                                         09060000
*                   ASINH = (ATAN15(/X/)/SQRT(1+X**2))/ X / /X/         09120000
*                                                                       09180000
ASINH    LPDR  6,2                 FR6 TRANSPARENT TO SQRT              09240000
         MDR   2,2                                                      09300000
         AD    2,ONE                                                    09360000
         BAL   3,SQRT              SQRT (1+X**2)                        09420000
         CD    6,ATANHC9                                                09480000
         BNL   ASINHIGH            DETERMINE WHICH METHOD               09540000
         DDR   6,0                                                      09600000
         LDR   2,6                                                      09660000
         BAL   4,ATANH15                                                09720000
ASINHRTN L     LKR,SAVELKR                                              09780000
         TM    BUFF,X'80'          RESULT = RESULT * SIGNUM (X)         09840000
         BCR   8,LKR BZR                                                09900000
         LCER  0,0                                                      09960000
         BR    LKR                 RETURN                               10020000
ASINHIGH ADR   0,6                 METHOD1                              10080000
         LDR   2,0                                                      10140000
         ICALL EXMLOG,*            COMPUTE LOG                          10200000
         B     ASINHRTN                                                 10260000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -3  O  X'   10320000
*                                                                       10380000
*        ARCTANGENT FUNCTION                                            10440000
*                                                                       10500000
*              -3  CIRCLE  X                                            10560000
*                                                                       10620000
*              1. REDUCE THE CASE TO THE 1ST OCTANT BY USING            10680000
*                   ATAN(-X) = -ATAN(X), ATAN(1/X) = PI/2-ATAN(X).      10740000
*              2. REDUCE FURTHER TO THE CASE /X/ LESS THAN TAN(PI/12)   10800000
*                   BY ATAN(X) PI/6+ATAN((X*SQRT3-1)/(X+SQRT3)).        10860000
*              3. FOR THE BASIC RANGE ( X LESS THAN TAN(PI/12)), USE    10920000
*                   A FRACTIONAL APPROXIMATION.                         10980000
*                                                                       11040000
ATAN     LPDR  0,2                 SET SIGN POSITIVE                    11100000
         LD    4,ONE                                                    11160000
         SR    1,1                 GR1, GR2 FOR DISTINGUISHING CASES    11220000
         LA    2,ATANQQ                                                 11280000
         CER   0,4                                                      11340000
         BNP   ATANSK1                                                  11400000
         LDR   2,4                 IF X GREATER THAN 1, TAKE INVERSE    11460000
         DDR   2,0                   AND INCREMENT GR1 BY 16            11520000
         LDR   0,2                                                      11580000
         LA    1,16                                                     11640000
ATANSK1  CE    0,UNFLO             IF ARG LESS THAN 16**-7, ANS=ARG.    11700000
         BNP   ATANRDY             THIS AVOIDS UNDERFLOW EXCEPTION      11760000
         CE    0,TAN15                                                  11820000
         BNP   ATANSK2                                                  11880000
         LDR   2,0                 IF X GREATER THAN TAN(PI/12),        11940000
         MD    0,RT3M1               REDUCE X TO (X*SQRT3-1)/(X+SQRT3)  12000000
         SDR   0,4                 COMPUTE X*SQRT3-1 AS                 12060000
         ADR   0,2                 X*(SQRT3)-1+X                        12120000
         AD    2,RT3                     TO GAIN ACCURACY               12180000
         DDR   0,2                                                      12240000
         LA    2,8(2)              INCREMENT GR2 BY 8                   12300000
ATANSK2  LDR   6,0                 COMPUTE ATAN OF REDUCED ARGUMENT BY  12360000
         MDR   0,0                 ATAN(X) = X+X*X**2*F, WHERE          12420000
         LD    4,ATANC7              F = C1+C2/(X**2+C3+C4/             12480000
         ADR   4,0                     (X**2+C5+C6/(X**2+C7)))          12540000
         LD    2,ATANC6                                                 12600000
         DDR   2,4                                                      12660000
         AD    2,ATANC5                                                 12720000
         ADR   2,0                                                      12780000
         LD    4,ATANC4                                                 12840000
         DDR   4,2                                                      12900000
         AD    4,ATANC3                                                 12960000
         ADR   4,0                                                      13020000
         LD    2,ATANC2                                                 13080000
         DDR   2,4                                                      13140000
         AD    2,ATANC1                                                 13200000
         MDR   0,2                                                      13260000
         MDR   0,6                                                      13320000
         ADR   0,6                                                      13380000
ATANRDY  AD    0,0(1,2)            DEPENDING ON THE CASE,               13440000
         LNR   1,1                   EITHER ADD 0 OR PI/6, OR           13500000
         SD    0,ATANQQ(1)             SUBTRACT FROM PI/3 OR PI/2       13560000
         LPER  0,0                                                      13620000
         B     ASINHRTN            RETURN WITH R = R * SIGNUM (R)       13680000
     TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -1  -2  O  X'   13740000
*                                                                       13800000
*        ARC SINE FUNCTION                                              13860000
*                                                                       13920000
*              -1  CIRCLE  X                                            13980000
*                                                                       14040000
*        ARC COSINE FUNCTION                                            14100000
*                                                                       14160000
*              -2  CIRCLE  X                                            14220000
*                                                                       14280000
*              1. IF X BETWEEN 0 AND 1/2, COMPUTE ARCSIN BY RATIONAL    14340000
*              2. IF X BETWEEN 1/2 AND 1,                               14400000
*                   ARCSIN(X) = PI/2-2*ARCSIN(SQRT((1-X)/2))            14460000
*              3. IF X NEGATIVE, ARCSIN(X) = - ARCSIN(/X/)              14520000
*              4. ARCCOS(X) = PI/2-ARCSIN(X)                            14580000
*                                                                       14640000
ACOS     MVI   SWITCH,X'00'        SET SWITCH TO COS                    14700000
         B     ACOSJOIN                                                 14760000
ASIN     MVI   SWITCH,X'80'        SET SWITCH TO SIN                    14820000
ACOSJOIN LDR   6,2                                                      14880000
         LPDR  2,2                 /X/ TO FR2                           14940000
         CE    2,HALF              IF /X/ SMALLER THAN 1/2, SKIP TO     15000000
         BNH   MINMAX                MINMAX SECTION                     15060000
         LNER  2,2                 COMPUTE 1-/X/                        15120000
         AD    2,ONE                                                    15180000
         BM    RNGERR              IF /X/ GREATER THAN 1, ERROR         15240000
         HDR   6,2                 LET Z = SQRT((1-/X/)/2),             15300000
         ADR   2,2                   KEEP Z**2 IN FR6 AND COMPUTE       15360000
         BAL   3,SQRT                                                   15420000
         B     ACOSMRG             MERGE WITH MINMAX EVALUTION          15480000
MINMAX   OI    SWITCH,X'40'                                             15540000
         LDR   0,2                                                      15600000
         CE    0,UNFLO             IF /X/ IS SMALLER THAN 16**-7,       15660000
         BH    *+6                   SUBSTITUTE 0 FOR X**2 TO AVOID     15720000
         SDR   6,6                     UNDERFLOW MESSAGE.               15780000
         MDR   6,6                 FOR /X/ LE 1/2, GET X**2 IN FR6      15840000
ACOSMRG  LD    4,ACOSC5            COMMON CIRCIUT                       15900000
         ADR   4,6                   COMPUTE ARCSIN(/X/)                15960000
         LD    2,ACOSD4                OR 2*ARCSIN(Z) AS THE CASE MAY B 16020000
         DDR   2,4                                                      16080000
         AD    2,ACOSC4              FR0 CONTAINS /X/ OR 2*Z            16140000
         ADR   2,6                   FR6 CONTAINS X**2 OR Z**2          16200000
         LD    4,ACOSD3                                                 16260000
         DDR   4,2                 USE MINIMAX APPROXIMATION OF FORM,   16320000
         AD    4,ACOSC3                                                 16380000
         ADR   4,6                                                      16440000
         LD    2,ACOSD2                ARCSIN(W) = W+F*W**3  WHERE      16500000
         DDR   2,4                                                      16560000
         AD    2,ACOSC2                F = C1+D1/(WSQ+C2+D2/(WSQ+C3+D3  16620000
         ADR   2,6                                                      16680000
         LD    4,ACOSD1                      /(WSQ+C4+D4/(WSQ+C5))))    16740000
         DDR   4,2                                                      16800000
         AD    4,ACOSC1                                                 16860000
         MDR   4,6                                                      16920000
         MDR   4,0                   POSTPONE COMBINING FR4 AND FR0     16980000
         TM    SWITCH,X'C0'        IF ARSIN FOR BIG /X/ OR              17040000
         BNM   ACOSSIGN              ARCOS FOR SMALL /X/, SUBTRACT      17100000
         SD    4,ONE                   THE WORK FROM PI/2.  DO THIS     17160000
         SD    0,PO2M1                   CAREFULLY TO REDUCE ROUND-OFF  17220000
*                                          ERROR.                       17280000
ACOSSIGN ADR   0,4                 AT THIS POINT COMBINE FR6 AND FR0    17340000
         LPDR  0,0                   TO COMPLETE COMPUTATION OF ANS FOR 17400000
         TM    BUFF,X'80'              /X/                              17460000
         BCR   8,LKR BZR           IF ARG IS POSITIVE, DONE             17520000
         LNER  0,0                 IF ARG NEG AND ARSIN, SWITCH SIGN    17580000
         TM    SWITCH,X'80'        IF ARG NEGATIVE AND ARCOS,           17640000
         BCR   1,LKR BOR             SUBTRACT FR0 FROM PI               17700000
         AD    0,PI                                                     17760000
         BR    LKR                 RETURN                               17820000
     TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     -4  0  4  O  X' 17880000
*                                                                       17940000
*        ((X**2)+1)**.5  FUNCTION                                       18000000
*                                                                       18060000
*              4  CIRCLE  X                                             18120000
*                                                                       18180000
CIR4     CD    2,K8E16             IS IT WORTH THE BOTHER?         5988 18240000
         LDR   0,2                                                 5988 18300000
         BCR   11,LKR              BNLR  -- NO, RESULT IS ARGUMENT 5988 18360000
         LD    0,ONE               ((1-X)+(X(1+X)))*.5             5988 18420000
         LDR   4,0                                                      18480000
         SDR   0,2                                                      18540000
         ADR   4,2                                                      18600000
         MDR   2,4                                                      18660000
         ADR   2,0                                                      18720000
         B     CIRSQRT             GO TAKE SQRT OF FR2                  18780000
*                                                                       18840000
*                                                                       18900000
*        (1-X**2)**.5  FUNCTION                                         18960000
*                                                                       19020000
*              0  CIRCLE  X                                             19080000
*                                                                       19140000
CIR0     LD    0,ONE               ((1-X)*(1+X))*.5                     19200000
         LDR   4,0                                                      19260000
         SDR   0,2                                                      19320000
         ADR   2,4                                                      19380000
         MDR   2,0                                                      19440000
         B     CIRSQRT                                                  19500000
*                                                                       19560000
*                                                                       19620000
*        ((X**2)-1)**.5  FUNCTION                                       19680000
*                                                                       19740000
*              -4  CIRCLE  X                                            19800000
*                                                                       19860000
CIRM4    CD    2,K8E16             SHOULD WE DO IT?                5988 19920000
         LDR   0,2                                                 5988 19980000
         BCR   11,LKR              BNLR -- NO, ANSWER IS ARGUMENT  5988 20040000
         LD    0,ONE               ((X-1)*(X+1))*.5                5988 20100000
         LDR   4,0                                                      20160000
         ADR   4,2                                                      20220000
         SDR   2,0                                                      20280000
         MDR   2,4                                                      20340000
CIRSQRT  BAL   3,SQRT              TAKE SQRT OF FR2                     20400000
         BR    LKR                 RETURN                               20460000
     TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     1  2  O  X'     20520000
*                                                                       20580000
*        SINE FUNCTION                                                  20640000
*                                                                       20700000
*              1  CIRCLE  X                                             20760000
*                                                                       20820000
*        COSINE FUNCTION                                                20880000
*                                                                       20940000
*              2  CIRCLE  X                                             21000000
*                                                                       21060000
*              1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT        21120000
*                   AND FRACTION.                                       21180000
*              2. IF COSINE, ADD 2 TO OCTANT NUMBER.                    21240000
*              3. IF SINE, ADD 0(4) TO OCTANT NUMBER FOR +ARG(-ARG).    21300000
*              4. COMPUTE SINE OR COSINE OF FRACTION*PI/4 DEPENDING     21360000
*                   ON THE OCTANT.                                      21420000
*              5. IF OCTANT NUMBER IS FOR LOWER PLANE, MAKE SIGN -.     21480000
*                                                                       21540000
*                                                                       21600000
*              LOW PREC TAN ASSUMES FR6 UNCHANGED BY SIN                21660000
*                                                                       21720000
COS      LA    0,2                 FOR COSINE, OCTANT CRANK IS 2        21780000
*                                    COS(X) = SIN(PI/2+X)               21840000
         B     COSMERGE            ADJUST BASE REGISTER AND MERGE       21900000
SIN      SR    0,0                 FOR SINE, OCTANT CRANK IS 0 IF + ARG 21960000
*                                            OCTANT CRANK IS 4 IF - ARG 22020000
         TM    BUFF,X'80'          SIN(-X) = SIN(PI+X)                  22080000
         BZ    COSMERGE                                                 22140000
         LA    0,4                                                      22200000
COSMERGE LDR   0,2                 PICK UP THE ARGUMENT                 22260000
         LPER  0,0                 FORCE SIGN OF ARG TO +               22320000
         CE    0,MAX                                                    22380000
         BNL   RNGERR              ERROR IF /X/ GRT THAN OR = PI*2**50  22440000
         DD    0,PIOV4             DIVIDE BY PI/4 AND SEPARATE INTEGER  22500000
         LDR   2,0                   PART AND FRACTION PART OF QUOTIENT 22560000
         AW    2,DUNZERO           FORCE CHARACTERISTIC X'4E'           22620000
         STD   2,BUFF2             INTEGER PART UNNORMALIZED = OCTANT   22680000
         AD    2,DUNZERO           INTEGER PART NORMALIZED = OCTANT     22740000
         SDR   0,2                 FRACTION PART TO FR0                 22800000
         AL    0,BUFF2+4           ADJUST OCTANT NUMBER WITH CRANK      22860000
         ST    0,BUFF2               AND SAVE IT                        22920000
         TM    BUFF2+3,X'01'       IF ODD OCTANT, TAKE COMPLEMENT       22980000
         BZ    COSEVEN               OF FRACTION TO OBTAIN MODIFIED ARG 23040000
         SD    0,ONE                                                    23100000
COSEVEN  LPDR  4,0                                                      23160000
         SR    1,1                 GR1 = 0 FOR COSINE POLYNOMIAL        23220000
         TM    BUFF2+3,X'03'         THIS IS FOR OCTANT 2, 3, 6, 7      23280000
         BM    *+8                 GR1 = 8 FOR SINE POLYNOMIAL          23340000
         LA    1,8                   THIS IS FOR OCTANT 1, 4, 5, OF 8   23400000
         CE    4,UNFLO             IF X IS LESS THAN 16$$-7, SET X TO 0 23460000
         BH    *+6                   THIS PREVENTS UNDERFLOW            23520000
         SDR   0,0                                                      23580000
         MDR   0,0                 COMPUTE SINE OR COSINE OF MODIFIED   23640000
         LDR   2,0                   ARG USING PROPER CHEBYSHEV         23700000
         MD    0,COSC7(1)              INTERPOLATION POLYNOMIAL         23760000
         AD    0,COSC6(1)                                               23820000
         MDR   0,2                 SIN(X)/X POLYNOMIAL OF DEG 6 IN X**2 23880000
         AD    0,COSC5(1)          COS(X) POLYNOMIAL OF DEG 7 IN X**2   23940000
         MDR   0,2                                                      24000000
         AD    0,COSC4(1)                                               24060000
         MDR   0,2                                                      24120000
         AD    0,COSC3(1)                                               24180000
         MDR   0,2                                                      24240000
         AD    0,COSC2(1)                                               24300000
         MDR   0,2                                                      24360000
         AD    0,COSC1(1)                                               24420000
         LTR   1,1                                                      24480000
         BZ    COSF                                                     24540000
         MDR   0,4                 COMPLETE SINE POLYNOMIAL BY          24600000
         B     COSSIGN               MULTIPLYING BY X                   24660000
COSF     MDR   0,2                 COMPLETE COSINE POLYNOMIAL           24720000
         AD    0,ONE                 (ONE MORE DEGREE)                  24780000
COSSIGN  TM    BUFF2+3,X'04'       IF MODIFIED OCTANT IS IN             24840000
         BCR   8,LKR BZR             LOWER PLANE, SIGN IS NEGATIVE      24900000
         LNER  0,0                                                      24960000
         BR    LKR                 RETURN                               25020000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E      3  O  X'   25080000
         AIF   (NOT &HIPREC).HIPREC5                                    25140000
*                                                                       25200000
*        TANGENT FUNCTION                                               25260000
*                                                                       25320000
*              3  CIRCLE  X                                             25380000
*                                                                       25440000
*              1. DIVIDE MAGNITUDE OF ARG BY PI/4 TO FIND OCTANT AND    25500000
*                   FRACTION.  REDUCED ARGUMENT W IS EITHER THIS        25560000
*                   FRACTION OR ITS COMPLEMENT.  THE MAGNITUDE OF THE   25620000
*                   ANSWER IS TAN(W*PI/4).                              25680000
*              2. IF /ARG/ IS EQUAL OR GREATER THAN PI*2**50,           25740000
*                   DOMAIN ERROR.                                       25800000
*              3. IF ARG IS SO CLOSE TO ONE OF SINGULARITIES OF THE     25860000
*                   FUNCTION THAT THE COMBINED EFFECT OF COMPUTATIONAL  25920000
*                   ERROR AND MINMAL INPUT ERROR CAN CAUSE RELATIVE     25980000
*                   ERROR OF 1/5, DOMAIN ERROR.                         26040000
*                                                                       26100000
TAN      MVC   BUFFQ(8),INDEX      INITIALIZE TESTING GUAGE             26160000
         LD    4,ONE               PRELOAD FR4 WITH 1.0                 26220000
         LPDR  0,2                 OBTAIN /ARG/ IN FR0                  26280000
         CE    0,MAX                                                    26340000
         BNL   RNGERR              IF /ARG/ TOO BIG, DOMAIN ERROR.      26400000
         DD    0,PIOV4             LET W = /ARG/ DIVIDED BY PI/4        26460000
         STE   0,BUFF2                                                  26520000
         MVC   BUFFQ(1),BUFF2   GIVE CHAR OF QUOTIENT TO TESTING GUAGE  26580000
         MVI   BUFF2+7,X'00'       CLEAR LOW PART OF OCTANT             26640000
         CER   0,4                                                      26700000
         BL    TANJOIN                                                  26760000
         LDR   2,0                 IF QUOTIENT HAS INTEGER PART,        26820000
         AW    2,SCALER              ISOLATE IT IN FR2 (UNNORMALIZED),  26880000
         STD   2,BUFF2               SAVE IT (LAST BITS ARE FOR OCTANT) 26940000
         AD    2,SCALER              NORMALIZE IT AND SUBTRACT IT FROM  27000000
         SDR   0,2                   FR0 TO OBTAIN FRACTION PART.       27060000
         TM    BUFF2+7,X'01'                                            27120000
         BE    TANJOIN             IF EVEN OCTANT, MODIFIED ARG W RDY   27180000
         SDR   0,4                 IF ODD OCTANT, W= 1-FRACTION         27240000
TANJOIN  LPDR  6,0                 LEAVE W IN FR6, AND + OR -W IN FR0   27300000
         LD    2,TANB3                                                  27360000
         CE    6,TANUNFLO                                               27420000
         BL    TANSKIP             LET U=WSQ IF W IS AT LEAST 2**-46    27480000
         MDR   0,0                   AND COMPUTE TWO POLYNOMIALS        27540000
         LDR   4,0                                                      27600000
         AD    4,TANA2               P(W) = W*(A0+A1*U+A2*U**2+U**3)    27660000
         MDR   4,0                                                      27720000
         AD    4,TANA1               Q(W) = B0+B1*U+B2*U**2+B3*U**3     27780000
         MDR   2,0                                                      27840000
         AD    2,TANB2             IF W IS LESS THAN 2**-46, LET        27900000
         MDR   2,0                   U = + OR -W, AND SUBSTITUTE AS     27960000
         AD    2,TANB1               FOLLOWS TO AVOID INTERMEDIATE      28020000
TANSKIP  MDR   2,0                   UNDERFLOW OF SQUARING W.           28080000
         AD    2,TANB0                                                  28140000
         MDR   0,4                   P(W) = W*(A0+U)                    28200000
         AD    0,TANA0               Q(W) = B0+B3*U                     28260000
         MDR   0,6                                                      28320000
         TM    BUFF2+7,X'03'                                            28380000
         BM    TANXX                                                    28440000
         DDR   0,2                 IF OCTANT IS 0 OR 3 (MOD 4),         28500000
         B     TANSIGN              THE ANSWER IS TAN(W*PI/4)=P(W)/Q(W) 28560000
*                                                                       28620000
TANXX    CD    6,BUFFQ             IF OCTANT IS 1 OR 2 (MOD 4), AND IF  28680000
         BNH   RNGERR                W IS TOO SMALL, SINGULAR TROUBLE   28740000
         DDR   2,0                 OTHERWISE, THE ANSWER IS             28800000
         LDR   0,2                   COTAN(W*PI/4)=Q(W)/P(W)            28860000
*                                                                       28920000
TANSIGN  TM    BUFF2+7,X'02'       IF OCTANT IS 2 OR 3 (MOD 4),         28980000
         BZ    ASINHRTN              CHANGE SIGN OF ANSWER              29040000
         LCER  0,0                                                      29100000
         B     ASINHRTN                                                 29160000
*                                                                       29220000
         AGO   .HIPREC6                                                 29280000
.HIPREC5 ANOP                                                           29340000
*                                                                       29400000
*        TANGENT FUNCTION                                               29460000
*                                                                       29520000
*              3  CIRCLE  X                                             29580000
*                                                                       29640000
*              TAN(X) = SIN(X)/COS(X)                                   29700000
*                                                                       29760000
TAN      BAL   LKR,COS             COMPUTE COS(X)                       29820000
         LDR   6,0                 FR6 TRANSPARENT TO SIN               29880000
         LD    2,BUFF                                                   29940000
         BAL   LKR,SIN             COMPUTE SIN(X)                       30000000
         DDR   0,6                 TAN(X) = SIN(X)/COS(X)               30060000
         L     LKR,SAVELKR         RESTORE LINK REGISTER                30120000
         BR    LKR                 RETURN                               30180000
.HIPREC6 ANOP                                                           30240000
     TITLE 'EXCIRCLE    D Y A D I C     C I R C L E     5  6  O  X'     30300000
*                                                                       30360000
*        HYPERBOLIC SINE FUNCTION                                       30420000
*                                                                       30480000
*              5  CIRCLE  X                                             30540000
*                                                                       30600000
*        HYPERBOLIC COSINE FUNCTION                                     30660000
*                                                                       30720000
*              6  CIRCLE  X                                             30780000
*                                                                       30840000
*              SINH(X) = (E**X-E**(-1))/2                               30900000
*              COSH(X) = (E**X+E**(-1))/2                               30960000
*              SINH FOR SMALL X IS COMPUTED DIRECTLY BY POLYNOMIAL.     31020000
*              FOR OTHER CASES, ELABORATE USE OF $EXP IS MADE.          31080000
*                                                                       31140000
COSH     MVI   SWITCH,X'00'        SET INSTR SWITCH TO 'COSH'           31200000
         B     COSHJOIN            JOIN WITH COMMON CIRCUIT             31260000
SINH     MVI   SWITCH,X'01'        SET INSTR SWITCH TO 'SINH'           31320000
COSHJOIN LDR   4,2                 OBTAIN ARG X IN FR4                  31380000
         LPDR  0,2                 /X/ TO FR0                           31440000
         TM    SWITCH,X'01'                                             31500000
         BZ    COSHEXP1            IF COSH ENTRY, SKIP                  31560000
         CE    0,LIMIT                                                  31620000
         BNL   COSHEXP2            IF SINH, AND /X/ GE 0.88137, SKIP    31680000
         CE    0,COSHC6            IF SINH, AND /X/ LE 0.1626E-9, AVOID 31740000
         BL    COSHSIGN              INTERMEDIATE UNDERFLOW, ANS = X    31800000
         MDR   0,0                                                      31860000
         LDR   2,0                                                      31920000
         MD    0,COSHC6            FOR SINH OF MODEST ARGUMENT, USE     31980000
         AD    0,COSHC5                                                 32040000
         MDR   0,2                 SINH(X) = X+X*XSQ*F(XSQ)             32100000
         AD    0,COSHC4                                                 32160000
         MDR   0,2                 WHERE F(XSQ) IS A POLYNOMIAL         32220000
         AD    0,COSHC3                                                 32280000
         MDR   0,2                 OF DEGREE 5 IN XSQ                   32340000
         AD    0,COSHC2                                                 32400000
         MDR   0,2                 USE OF EXPONENTIAL FOR THESE         32460000
         AD    0,COSHC1            ARGUMENTS WOULD RESULT IN A          32520000
         MDR   0,2                 LOSS OF ACCURACY                     32580000
         MDR   0,4                                                      32640000
         ADR   0,4                                                      32700000
         BR    LKR                 RETURN                               32760000
COSHEXP1 LPER  4,4                 COSH(X) IS ALWAYS POSITIVE           32820000
COSHEXP2 CE    0,MAXI                                                   32880000
         BH    RNGERR              IF /X/ TOO LARGE, GIVE ERROR         32940000
         AD    0,LNV                                                    33000000
         LDR   2,0                                                      33060000
         ST    LKR,SAVELKR2        SAVE LKR AGAIN TO KEEP OUR GOOD      33120000
*                                  FRIEND LOW-PRECISION TANH HAPPY.     33180000
         ICALL EXMEXP,*            CALL EXP                             33240000
         L     LKR,SAVELKR2        RESTORE LINK REG                     33300000
         LD    2,VSQ               COMPUTE V**2/EXP(/X/+LOG(V))         33360000
         DDR   2,0                                                      33420000
         TM    SWITCH,X'01'                                             33480000
         BO    SINHXX                                                   33540000
         LPER  2,2                 COSH                                 33600000
         B     COSHXX                                                   33660000
SINHXX   LNER  2,2                 SINH                                 33720000
COSHXX   LDR   6,0               SPECIAL MANEUVER TO MINIMIZE ROUNDING  33780000
         ADR   0,2                   ERROR IN EFECTIVELY EVALUATING     33840000
         MD    0,DELTA                 (E**X + OR - E**-X)/2            33900000
         ADR   0,2               HERE DELTA IS SUCH THAT 1+DELTA=1/2V,  33960000
         ADR   0,6                   V IS CHOSEN SLIGHTLY LESS THAN 0.5 34020000
COSHSIGN LTER  4,4                                                      34080000
         BCR   10,LKR           IF X IS NEGATIVE, SINH(X) = -SINH(/X/)  34140000
         LNER  0,0                                                      34200000
         BR    LKR                                                      34260000
         TITLE 'EXCIRCLE    D Y A D I C     C I R C L E      7  O  X'   34320000
         AIF   (&HIPREC EQ 0).HIPREC1                                   34380000
*                                                                       34440000
*        HYPERBOLIC TANGENT FUNCTION                                    34500000
*                                                                       34560000
*              7  CIRCLE  X                                             34620000
*                                                                       34680000
*              1. IF /X/ LESS THAN 0.54931, USE A FRACTION APPROX.      34740000
*              2. IF /X/ GREATER THAN 20.101, ANSWER IS +1 OR -1.       34800000
*              3. FOR OTHER VALUE OF X, USE EXTERNAL DEXP FUNCTION.     34860000
*                                                                       34920000
TANH     LDR   6,2                 OBTAIN ARGUMENT X                    34980000
         LD    4,ONE               FR4 AND FR6 TRANSPARENT TO DEXP      35040000
         LPER  2,2                 /X/ TO FR2                           35100000
         CE    2,MLIM                                                   35160000
         BNH   TANHSML             IF /X/ LESS THAN 0.54931, JUMP       35220000
         CE    2,HLIM              IF /X/ GREATER THAN 20.101           35280000
         BNL   TANHBIG               ANS = + OR -1, JUMP                35340000
         ADR   2,2                 FOR /X/ BETWEEN 0.54931 AND 20.101,  35400000
*                                    /ANS/ = 1-2/(1+E**/2X/)            35460000
         BAL   LKR,EXMEXP          CALL EXP                             35520000
         L     LKR,SAVELKR                                              35580000
         ADR   0,4                                                      35640000
         LDR   2,4                                                      35700000
         ADR   2,2                                                      35760000
         DDR   2,0                                                      35820000
         LDR   0,4                                                      35880000
         SDR   0,2                                                      35940000
TANHSIGN LTER  6,6                 TANH(/X/) READY, ADJUST SIGN         36000000
         BCR   10,LKR                                                   36060000
         LNER  0,0                                                      36120000
         BR    LKR                 RETURN                               36180000
TANHBIG  LDR   0,4                 CASE OF BIG ARGUMENT                 36240000
         B     TANHSIGN                                                 36300000
TANHSML  LDR   0,2                                                      36360000
         CE    2,UNFLO             IF /X/ LESS THAN 2**-28, ANS = ARG.  36420000
         BC    12,TANHSIGN                                              36480000
         MDR   0,0                 /X/ SMALLER THAN 0.54931             36540000
         LD    4,TANHC5              TANH(X) = X+X*F, WHERE             36600000
         ADR   4,0                     F = C0*X**2/(X**2+C1+C2/         36660000
         LD    2,TANHC4                  (X**2+C3+C4/(X**2+C5)))        36720000
         DDR   2,4                                                      36780000
         AD    2,TANHC3                                                 36840000
         ADR   2,0                                                      36900000
         LD    4,TANHC2                                                 36960000
         DDR   4,2                                                      37020000
         AD    4,TANHC1                                                 37080000
         ADR   4,0                                                      37140000
         MD    0,TANHC0                                                 37200000
         DDR   0,4                                                      37260000
         MDR   0,6                                                      37320000
         ADR   0,6                                                      37380000
         BR    LKR                 RETURN                               37440000
         AGO   .HIPREC2                                                 37500000
.HIPREC1 ANOP                                                           37560000
*                                                                       37620000
*        HYPERBOLIC TANGENT FUNCTION                                    37680000
*                                                                       37740000
*              7  CIRCLE  X                                             37800000
*                                                                       37860000
*              1. IF /X/ GT 18.368400, RETURN + OR - 1.                 37920000
*              2. IF 2 LT /X/ LE 18.368400,                             37980000
*                   TANH(X) = SIGN(X)*1-2/1+EXP( /2*X/ ).               38040000
*              3. IF /X/ GE 2, TANH(X) = SINH(X) / COSH(X).             38100000
*                                                                       38160000
TANH     LPDR  0,2                 TAKE ABS VALUE OF ARG                38220000
         LD    6,ONE               FR 6 PRESERVED BY EXMEXP             38280000
         CD    0,TANHC18           IF ARG GT 18.36840028483855,         38340000
         BH    TANH2                 USE LARGE METHOD.                  38400000
         CE    0,TWO               IF ARG BETWEEN 2 AND 18.3684002848   38460000
         BH    TANH1                 USE INTERMEDIATE METHOD.           38520000
         BAL   LKR,COSH            COSH(X)                              38580000
         LD    2,BUFF                                                   38640000
         STD   0,BUFF                                                   38700000
         BAL   LKR,SINH            SINH(X)                              38760000
         DD    0,BUFF                                                   38820000
         L     LKR,SAVELKR         TANH(X) = SINH(X)/COSH(X)            38880000
         BR    LKR                 RETURN                               38940000
TANH1    LDR   2,0                 INTERMEDIATE METHOD (2.)             39000000
         ADR   2,2                                                      39060000
         ICALL EXMEXP,*            COMPUTE EXP( /X*X/ )                 39120000
         ADR   0,6                                                      39180000
         LD    2,TWO                                                    39240000
         DDR   2,0                                                      39300000
         SDR   6,2                                                      39360000
TANH2    LDR   0,6                                                      39420000
         B     ASINHRTN            RETURN R = R * SIGNUM (R)            39480000
*                                                                       39540000
.HIPREC2 ANOP                                                           39600000
*                                                                       39660000
         DROP  9,TLR                                                    39720000
         TITLE 'EXEXP    D Y A D I C     E X P O N E N T I A T I O N'   39780000
*                                                                       39840000
*        EXPONENTIATION..  C = A EXP B                                  39900000
*                                                                       39960000
         ENTRY EXEXP                                                    40020000
         USING LOCAL,TLR                                                40080000
         USING *,9                                                      40140000
EXEXP    ST    LKR,SAVELKR                                              40200000
         MVI   RESSIGN,0                                                40260000
         STM   5,8,BUFF                                                 40320000
         LD    4,ONE               USED FREQUENTLY                      40380000
         LTER  2,2                                                      40440000
         BP    BPOSITIV                                                 40500000
         BM    BNEG                                                     40560000
         LDR   0,4                 ZERO B GIVES RESULT OF 1             40620000
         BR    LKR                                                      40680000
BNEG     LDR   6,4                 B NEG, RECIPROCATE A                 40740000
         LTER  0,0                 AND MAKE B POSITIVE                  40800000
         BZ    RNGERR              0*NEGATIVE GIVES DOMAIN ERROR        40860000
*        CANNOT RELY ON DIV BY 0 IN F0 GIVING DOMAIN ERROR              40920000
         DDR   6,0                                                      40980000
         LDR   0,6                                                      41040000
         LPDR  2,2                                                      41100000
BPOSITIV STD   0,A                                                      41160000
         STD   2,B                                                      41220000
         CD    2,HALF              TRAP FOR FAST SQRT                   41280000
         BNE   BN2                                                      41340000
         LDR   2,0                                                      41400000
         BAL   3,SQRT                                                   41460000
         B     EXPDUN                                                   41520000
BN2      AW    2,DUNZERO           IF B IS A TRUE INTEGER WE CAN DO     41580000
         STD   2,DSTORE            EFFICIENT POWERING.                  41640000
         LTER  2,2                                                      41700000
         BNZ   TESTA               MUCH TOO BIG FOR THAT                41760000
         AD    2,DUNZERO           RENORMALIZE INTEGER PART OF ABS B    41820000
         SE    2,B                 DON'T NEED TO COMPARE LOW-ORDER PART 41880000
*                                  SINCE NUMBER BIGGER THAN 1534 WILL   41940000
*                                  BE REJECTED ANYWAY                   42000000
         BNZ   TESTA               NONINTEGER                           42060000
         L     3,DSTORE+4          NOW R3 = ABS B                       42120000
         CL    3,LARGINT           SEE IF B IS SMALL ENOUGH.            42180000
         BH    TESTA               BRANCH IF NOT.                       42240000
*                                                                       42300000
*              F0 IS STILL A                                            42360000
*              F4 IS 1.0                                                42420000
LOOP     ST    3,FTEMP             STORE EXPONENT SO WE CAN LOOK AT IT. 42480000
         TM    FTEMP+3,1           SEE IF LOW ORDER BIT IS 1.           42540000
         BZ    SKPMPY              IF NOT, FORGET IT.                   42600000
         MDR   4,0                 IF SO, MULTIPLY RES BY CUR POWER.    42660000
SKPMPY   SRA   3,1                 NOW, SHIFT EXP RIGHT ONE.            42720000
         BZ    DIDIT               IF IT'S NOW ZERO, WE'RE DONE.        42780000
         MDR   0,0                 IF NOT, SQUARE.                      42840000
         B     LOOP                AND SEE IF WE NEED IT.               42900000
DIDIT    LDR   0,4                                                      42960000
         BR    LKR                                                      43020000
*                                                                       43080000
TESTA    LTER  0,0                 0*POSITIVE IS JUST 0                 43140000
         BCR   8,LKR  BZR                                               43200000
         BP    EXPIT                                                    43260000
*                                                                       43320000
*        HERE WE HANDLE THE CASE A LT ZERO.                             43380000
*        DETERMINT IF B IS RATIONAL (=P/Q), THEN ..                     43440000
*        P ODD, Q ODD, - C = -(ABS A) EXP B.                            43500000
*        P EVEN, Q ODD - C = (ABS A) EXP B                              43560000
*        P ODD, Q EVEN - C = UNDEFINED.                                 43620000
*                                                                       43680000
*        B IRRATIONAL - C = -(ABS A) EXP B                              43740000
*                                                                       43800000
*        REGISTERS ..                                                   43860000
*        FLOATING ..                                                    43920000
*        0 - B                                                          43980000
*        2 - T                                                          44040000
*        4 - 1.0                                                        44100000
*        6 - E                                                          44160000
*        GENERAL ..                                                     44220000
*        5 - N                                                          44280000
*                                                                       44340000
         LA    5,EXEXPLIM          MAX NUMBER OF ITERATIONS (TO AVOID   44400000
*                                  'RATIONALS' WITH ABSURDLY LARGE      44460000
*                                  NUMERATORS AND DENOMINATORS)         44520000
         LD    6,RELERR            TOLERANCE FOR RATIONAL VS IRRAT      44580000
         SR    4,4                 ASSUME DENOMINATOR IS EVEN           44640000
         LD    2,B                 SET T TO B.                          44700000
         CDR   2,4                                                      44760000
         BNL   FLOORT              INITIAL EXPONENT GEQ 1.0             44820000
         LDR   0,2                 LSS 1.0.  INVERT IT TO GET THINGS    44880000
         LA    4,3                 STARTED AND ASSUME EVEN/ODD          44940000
IT       LDR   2,4                 NEXT STEP OF CONTINUED FRACTION EXPN 45000000
         DDR   2,0                 DONE.                                45060000
         MDR   6,2                 ERROR BOUND GROWS AS SQUARE OF TERM  45120000
FLOORT   MDR   6,2                 IN CONTINUED FRACTION EXPANSION      45180000
         LDR   0,2                 T TO B.                              45240000
         AW    2,DUNZERO           TRUNCATE QUOTIENT                    45300000
         STD   2,DSTORE            TO DETERMINE PARITY OF FLOOR         45360000
         AD    2,DUNZERO           RENORMALIZE TO GET FRACTIONAL PART   45420000
         SDR   0,2                 INTO F0                              45480000
         LA    3,1                 TEST ITS PARITY                      45540000
         N     3,DSTORE+4                                               45600000
         AR    4,3                                                      45660000
         IC    4,PGT(4)            FOLLOW THE GRAPH BELOW               45720000
*                                                                       45780000
*        NOW, COMPUTE NEW ERROR TERM.                                   45840000
ERRCHK   AD    6,RELERR            E = 16**-13 + E * T**2               45900000
         CDR   6,0                 SEE IF B LT E.                       45960000
         BNL   RAT                 BRANCH IF SO.                        46020000
         BCT   5,IT                OTHERWISE, LOOP ON N.                46080000
         B     IRATNL              B IS ASSUMED IRRATIONAL              46140000
*                                                                       46200000
*        IF B IS RATIONAL, WE HAVE THREE POSSIBILITIES.                 46260000
RAT      IC    4,RT(4)                                                  46320000
         B     RAT(4)                                                   46380000
IRATNL   MVI   RESSIGN,1           PICK NEGATIVE REAL ROOT              46440000
REVA     NI    A,X'7F'             LOG REQUIRES A TO BE POSITIVE        46500000
*                                                                       46560000
*        HERE, WE PERFORM THE EXPONENTIATION, USING FORTRAN XPN.        46620000
EXPIT    LD    2,A                                                      46680000
         ICALL EXMLOG,*                                                 46740000
         MD    0,B                                                      46800000
         LDR   2,0                                                      46860000
         ICALL EXMEXP,*                                                 46920000
         CLI   RESSIGN,0           NOW POSSIBLY INVERT SIGN OF RESULT   46980000
         BE    EXPDUN                                                   47040000
         LNER  0,0                 CASE OF NEGATIVE BASE, IRRATIONAL    47100000
*                                  EXP OR RATIONAL ODD/ODD EXP          47160000
EXPDUN   LM    5,8,BUFF                                                 47220000
         L     LKR,SAVELKR                                              47280000
         BR    LKR                                                      47340000
ERR      B     RNGERR                                                   47400000
RT       DC    AL1(ERR-RAT,ERR-RAT,RAT-RAT,REVA-RAT,REVA-RAT,RAT-RAT)   47460000
         DC    AL1(IRATNL-RAT,IRATNL-RAT)                               47520000
*                                                                       47580000
         DROP  9,TLR                                                    47640000
         EJECT                                                          47700000
EXEXPLIM EQU   10                  MAX NO OF TERMS IN CONT FRAC EXPANS  47760000
PGT      DC    FL1'3,6,3,0,7,0,1,4,1'                                   47820000
*                                                                       47880000
*        PGT REPRESENTS THE DIRECTED GRAPH BELOW.  EVEN INTEGER         47940000
*        QUOTIENTS DEVELOPED IN THE RATIONAL APPROXIMATOR TAKE US       48000000
*        ACROSS THE DIAGRAM  ((0,3),(1,6),(4,7)) AND ODD INTEGER        48060000
*        QUOTIENTS TAKE US AROUND  ((0,6,4),(1,3,7)).  FUNNY NUMBERING  48120000
*        OF VERTICES PROVIDES A RELATIVELY COMPACT TRANSLATE TABLE.     48180000
*        THE 4- AND 2-BITS OF THE VERTEX NUMBERS DETERMINE PARITY OF    48240000
*        NUMERATOR AND DENOMINATOR OF THE RATIONAL APPROXIMANTS.        48300000
*                                                                       48360000
*                                                                       48420000
*                             0 - O/E                                   48480000
*                                *                                      48540000
*                               ***                                     48600000
*                              * * *                                    48660000
*                             *  *  *                                   48720000
*                            *   *   *                                  48780000
*                           *    *    *                                 48840000
*      1 - O/E ************************************* 7 - O/O            48900000
*               * *       *      *      *       * *                     48960000
*                *   *   *       *       *   *   *                      49020000
*                 *     *        *        *     *                       49080000
*                  *   *   *     *     *   *   *                        49140000
*                   * *       *  *  *       * *                         49200000
*                    *           *           *                          49260000
*                   * *       *  *  *       * *                         49320000
*                  *   *   *     *     *   *   *                        49380000
*                 *     *        *        *     *                       49440000
*                *   *   *       *       *   *   *                      49500000
*               * *       *      *      *       * *                     49560000
*      4 - E/O ************************************* 6 - O/O            49620000
*                           *    *    *                                 49680000
*                            *   *   *                                  49740000
*                             *  *  *                                   49800000
*                              * * *                                    49860000
*                               ***                                     49920000
*                                *                                      49980000
*                             3 - E/O                                   50040000
*                                                                       50100000
*                                                                       50160000
         TITLE 'SQRT     A P L / 3 6 0     S Q U A R E     R O O T'     50220000
*                                                                       50280000
*        SQUARE  ROOT  FUNCTION                                         50340000
*              1. WRITE X = M*16**(2P+Q), M MANTISSA, Q = 0 OR 1.       50400000
*              2. THEN SQRT(X) = SQRT(M*16**-Q)*16**(P+Q).              50460000
*                   P+Q IS THE EXPONENT OF THE ANSWER.                  50520000
*                                                                       50580000
*        CALLING SEQUENCE          BAL   3,SQRT                         50640000
*                                                                       50700000
*              FR 6 IS PRESERVED BY SQRT.                               50760000
*                                                                       50820000
         ENTRY SQRT                                                     50880000
         USING SQRT+2,4                                                 50940000
         USING LOCAL,TLR                                                51000000
SQRT     BALR  4,0                                                      51060000
         LDR   0,2                 OBTAIN ARGUMENT                      51120000
         LTDR  4,2                                                      51180000
         BL    RNGERR              IF NEGATIVE ARG, ERROR               51240000
         BCR   8,3                 IF ARG IS 0, ANSWER IS 0, RETURN     51300000
         MVC   SQRTB(4),SQRTBBBB   PUT B WHERE WE CAN PLAY WITH IT      51360000
         STE   4,BUFFQ                                                  51420000
         L     0,BUFFQ             COMPUTE TARGET CHARACTERISTIC - 8    51480000
         AL    0,BIAS          = X'31000000' CHAR OF X'41' MINUS 2*8    51540000
         SRDL  0,25                  LOW GR0 = X'40' +P+Q-8             51600000
         STC   0,BUFFQ             GIVE THIS CHARACTERISTIC TO M AND B  51660000
         STC   0,SQRTB               THIS SEEMINGLY ARTIFICIAL CHAR WAS 51720000
         LE    2,BUFFQ                 CHOSEN TO AID THE FINAL ROUNDING 51780000
         AE    2,SQRTB             (M+B)*16**(P+Q-8)                    51840000
         ME    2,SQRTA             A*(M+B)*16**(P+Q), A IS SCALED BY 8  51900000
         LTR   1,1                                                      51960000
         BC    10,*+8              IF Q=1, 1ST APPROX. Y0 IS READY      52020000
         AER   2,2                 IF Q=0, MULTIPLY BY 4 TO OBTAIN Y0   52080000
         AER   2,2                                                      52140000
         DER   4,2                 NEWTON-RAPHSON ITERATIONS            52200000
         AUR   4,2                                                      52260000
         HER   4,4           Y1 = (Y0+ARG/Y0)/2  IN SHORT PRECISION     52320000
         LER   2,0                                                      52380000
         DER   2,4                                                      52440000
         AUR   2,4                                                      52500000
         HER   2,2           Y2 = (Y1+ARG/Y1)/2  IN SHORT PRECISION     52560000
         LDR   4,0                                                      52620000
         DDR   4,2                                                      52680000
         AWR   4,2                                                      52740000
         HDR   4,4           Y3 = (Y2+ARG/Y2)/2  IN LONG PRECISION      52800000
         DDR   0,4           Y4 = (ARG/Y3-Y3)/2-D+D+Y3 FOR ROUNDING     52860000
         SDR   0,4                 1ST APPROX IS SO CHOSEN THAT         52920000
         HER   0,0                   ARG/Y3-Y3 IS LESS THAN 16**(P+Q-8) 52980000
         SU    0,SQRTB                 HENCE 'HER' IS GOOD ENOUGH       53040000
         AU    0,SQRTB             -D+D IS TO CHOP OFF EXCESS DIGITS    53100000
         ADR   0,4                   OF NEGATIVE VALUE (ARG/Y3-Y3)/2    53160000
         BR    3                   RETURN                               53220000
         DROP  4,TLR                                                    53280000
 TITLE 'EXMEXP     M O N A D I C     E X P O N E N T I A L'             53340000
*                                                                       53400000
*        MONADIC EXPONENTIAL FUNCTION                                   53460000
*                                                                       53520000
*              EXMEXP MAY BE CALLED AS AN OPERATOR OR VIA ICALL.        53580000
*              FR4 AND FR6 ARE PRESERVED BY EXMEXP.                     53640000
*                                                                       53700000
         ENTRY EXMEXP                                                   53760000
         USING LOCAL,TLR                                                53820000
EXMEXP   BALR  4,0                 WE ESTABLISH OUR OWN ADDRESSABILITY  53880000
         USING *,4                 FOR THE CONVENIENCE OF THE ROUTINES  53940000
*                                  WHICH CALL US.                       54000000
         LDR   0,2                 PUT ARG IN REGISTER 0                54060000
         CE    0,MEXPMAX           MAX = 63 * LOG16 = 174.67309         54120000
         BH    RNGERR              IF ARGUMENT GREATER THAN THIS, ERROR 54180000
         CE    0,MEXPMIN           MIN = -65 * LOG16 = -180.21867       54240000
         BNH   MEXPSML             IF ARG LESS THAN THIS, GIVE ANS = 0  54300000
*                                                                       54360000
         DD    0,LOGE2             Y = X*LOG2(E) BY ACCURATE DIVISION   54420000
         STE   0,BUFFQ             SAVE SIGN OF Y                       54480000
         LER   2,0                 DECOMPOSE Y = (-4A'-B'-C'/16)-D'     54540000
         AU    2,MEXPSCAL          BY FORCING CHARACTERISTIC OF X'45'   54600000
         STE   2,FIELDS            -4A'-B'-C'/16 IN FIELDS, UNNORMALIZD 54660000
         SDR   2,2                                                      54720000
         AE    2,FIELDS            NORMALIZE THIS AND SUBTRACT IT       54780000
         SDR   0,2                 FROM Y TO OBTAIN -D' IN FR0          54840000
         L     2,FIELDS                                                 54900000
*                                                                       54960000
         TM    BUFFQ,X'80'         IF Y NEGATIVE, SKIP                  55020000
         BO    MEXPRDY             IF Y NON-NEGATIVE,                   55080000
         SD    0,ONO16             -D = /D'/-1/16                       55140000
         LA    2,1(2)              -4A-B-C/16 = -(-4A'-B'-(C'+1)/16)    55200000
         LCR   2,2                 NOW IN ANY CASE, B, C, AND D ARE +   55260000
*                                                                       55320000
MEXPRDY  SR    3,3                                                      55380000
         SRDL  2,4                 C IN HIGH GR3                        55440000
         SRL   3,25                                                     55500000
         SRDL  2,2                 B IN HIGH GR3, C IN LOW GR3          55560000
         SLL   2,24                                                     55620000
         LCR   0,2                 A (IN SCALE B7) IN R0, CHAR MODIFIER 55680000
         SR    2,2                                                      55740000
         SLDL  2,2                 B IN GR2, 8*C IN GR3                 55800000
*                                                                       55860000
         LDR   2,0                 COMPUTE 2**-D BY USE OF              55920000
         ME    0,MEXPC6            CHEBYSHEV INTERPOLATION              55980000
         AD    0,MEXPC5            POLYNOMIAL OF DEGREE 6               56040000
         MDR   0,2                                                      56100000
         AD    0,MEXPC4                                                 56160000
         MDR   0,2                                                      56220000
         AD    0,MEXPC3                                                 56280000
         MDR   0,2                                                      56340000
         AD    0,MEXPC2                                                 56400000
         MDR   0,2                                                      56460000
         AD    0,MEXPC1                                                 56520000
         MDR   0,2                                                      56580000
         AD    0,HALF              ADD C0 = 1. IN 2 STEPS               56640000
         AD    0,HALF              TO PROTECT LAST DIGIT                56700000
*                                                                       56760000
         LTR   3,3                 MULTIPLY 2**(-C/16)                  56820000
         BZ    MEXPSK2             IN DOING SO, AVOID                   56880000
         CE    0,ONE               MULTIPLICATION BY 1.                 56940000
         BL    MEXPSK1                                                  57000000
         LD    0,MCONST-8(3)                                            57060000
         B     MEXPSK2                                                  57120000
MEXPSK1  MD    0,MCONST-8(3)                                            57180000
MEXPSK2  LTR   2,2                 MULTIPLY 2**(-B)                     57240000
         BZ    MEXPSK3             BY HALVING B TIMES                   57300000
         HDR   0,0                                                      57360000
         BCT   2,*-2                                                    57420000
MEXPSK3  STD   0,BUFFQ             ADD A TO CHARACTERISTIC              57480000
         A     0,BUFFQ                                                  57540000
         ST    0,BUFFQ                                                  57600000
         SDR   0,0                 NORMALIZE THE ANSWER JUST IN CASE    57660000
         AD    0,BUFFQ                                                  57720000
*                                                                       57780000
         BR    LKR                 RETURN                               57840000
MEXPSML  SDR   0,0                 IF X IS VERY LARGE NEGATIVE,         57900000
         BR    LKR                 GIVE 0 ANSWER                        57960000
*                                                                       58020000
         DROP  4,TLR                                                    58080000
         TITLE 'EXDLOG     D Y A D I C       L O G A R I T H M'         58140000
*                                                                       58200000
*        DYADIC LOGARITHM FUNCTION                                      58260000
*                                                                       58320000
*              A LOG B  <=  (LOG B) DIV LOG A                           58380000
*                                                                       58440000
         ENTRY EXDLOG                                                   58500000
         USING EXDLOG,9                                                 58560000
EXDLOG   LR    10,LKR              R10 IS PRESERVED BY MLOG             58620000
         LDR   6,2                 FR6 IS PRESERVED BY MLOG             58680000
         LDR   2,0                                                      58740000
         LD    0,LOGTEN                                                 58800000
         CD    2,TEN               MAKE A QUICK CHECK FOR VERY          58860000
         BE    EXDLOGX                                                  58920000
         LD    0,LOGTWO            COMMON LEFT ARGUMENTS                58980000
         CD    2,TWO                                                    59040000
         BE    EXDLOGX                                                  59100000
         ICALL EXMLOG,*            COMPUTE LOG A                        59160000
EXDLOGX  LDR   2,6                                                      59220000
         LDR   6,0                                                      59280000
         ICALL EXMLOG,*            COMPUTE LOG B                        59340000
         DDR   0,6                 (LOG B) DIV LOG A                    59400000
         LR    LKR,10                                                   59460000
         BR    LKR                                                      59520000
*                                                                       59580000
         DROP  9                                                        59640000
 TITLE 'EXMLOG     M O N A D I C     L O G A R I T H M'                 59700000
*                                                                       59760000
*        MONADIC LOGARATHM FUNCTION                                     59820000
*                                                                       59880000
*              WRITE X = (16**P)*(2**-Q)*M, Q BETWEEN 0 AND 3, AND      59940000
*              M BETWEEN 1/2 AND 1.  DEFINE A=1, B=0 IF M IS GREATER    60000000
*              THAN SQRT1/2, OTHERWISE A=1/2, B=1.                      60060000
*              WRITE Z = (M-A)/(M+A), THEN                              60120000
*              LOG(X) = (4P-Q-B)*LOG(2)+LOG((1+Z)/(1-Z))                60180000
*                                                                       60240000
*              EXMLOG MAY BE CALLED AS AN OPERATOR OR VIA ICALL.        60300000
*              FR6 AND R10 ARE PRESERVED BY EXMLOG.                     60360000
*                                                                       60420000
         ENTRY EXMLOG                                                   60480000
         USING LOCAL,TLR                                                60540000
EXMLOG   BALR  4,0                 WE ESTABLISH OUR OWN ADDRESSABILITY  60600000
         USING *,4                 FOR THE CONVENIENCE OF THE ROUTINES  60660000
*                                  WHICH CALL US.                       60720000
         STD   2,BUFFQ             PUT ARG INTO R0, R1                  60780000
         LM    0,1,BUFFQ                                                60840000
         MVC   IPART(8),IPSTART    SET UP FLOAT CONVERTER               60900000
         LTR   2,0                                                      60960000
         BNH   RNGERR              IF 0 OR NEGATIVE, ERROR              61020000
         SRDL  2,24                CHAR IN LOW R2, 1ST DIGIT IN HIGH R3 61080000
         SLL   2,2                                                      61140000
         STH   2,IPART+2           FLOAT 4*CHAR AND SAVE IT             61200000
         SR    2,2                                                      61260000
         SLDL  2,4                 1ST DIGIT IN R2                      61320000
         IC    2,TABLE(2)          NUMBER OF LEADING ZEROS (=Q) IN R2   61380000
         SLDL  0,0(2)                                                   61440000
         STM   0,1,BUFFQ                                                61500000
         MVI   BUFFQ,X'40'         M = FRACTION * 2 ** Q IN CELL BUFFQ  61560000
*                                                                       61620000
         LA    1,8                                                      61680000
         LD    0,BUFFQ             PICK UP M INTO FR0                   61740000
         CE    0,MLOGLIM           IF M GREATER THAN SQRT(2)/2, R1 = 8. 61800000
         BH    MLOGRDY                                                  61860000
         SR    1,1                 IF M LESS THAN SQRT2/2, R1=0         61920000
         LA    2,1(2)              AND CRANK R2 BY 1.  Q+B IN R2        61980000
*                                                                       62040000
MLOGRDY  LDR   2,0                 COMPUTE Z = (M-A)/(M+A), A = 1 OR .5 62100000
         SD    0,HALF              SUBTRACT A IN 2 STEPS TO PROTECT     62160000
         SD    0,ZERO(1)           THE LAST DIGIT.                      62220000
         AD    2,HALF(1)           M+A HAS ONLY 53 BITS.  NOT SERIOUS   62280000
         DDR   0,2                                                      62340000
         STD   0,BUFFQ                                                  62400000
*                                                                       62460000
         MDR   0,0                 COMPUTE LOG((1+Z)/(1-Z)              62520000
         LDR   2,0                 BY CHEBYSHEV INTERPOLATION           62580000
         MD    2,MLOGC7            POLYNOMIAL (IN ZSQ) OF DEGREE 7      62640000
         AD    2,MLOGC6                                                 62700000
         MDR   2,0                                                      62760000
         AD    2,MLOGC5                                                 62820000
         MDR   2,0                                                      62880000
         AD    2,MLOGC4                                                 62940000
         MDR   2,0                                                      63000000
         AD    2,MLOGC3                                                 63060000
         MDR   2,0                                                      63120000
         AD    2,MLOGC2                                                 63180000
         MDR   2,0                                                      63240000
         AD    2,MLOGC1                                                 63300000
         MDR   2,0                 F = ZSQ*(C1+ZSQ*(C2...+ZSQ*C7)...)   63360000
         LD    0,BUFFQ             LOG((1+Z)/(1-Z)) = Z*(2+F)           63420000
         MDR   2,0                                  = Z+Z+Z*F           63480000
         ADR   2,0                 TO GAIN ACCURACY                     63540000
         ADR   2,0                                                      63600000
*                                                                       63660000
         LD    0,IPART             4*CHARACTERISTIC IN FR0              63720000
         LA    2,256(2)            ADD 4*(BASE CHARAC=64) TO Q+B,       63780000
         STH   2,IPART+2           FLOAT THIS AND SUBTRACT FROM FR0     63840000
         SE    0,IPART             TO OBTAIN 4P-Q-B                     63900000
         MD    0,MLOGE2            MULTIPLY LOG(2) BASE E               63960000
         ADR   0,2                 AND ADD TO LOG((1+Z)/(1-Z))          64020000
         BR    LKR                                                      64080000
*                                                                       64140000
         DROP  4,TLR                                                    64200000
*                                                                       64260000
         TITLE 'EXBINOM     D Y A D I C       S H R I E K'              64320000
*        DYADIC SHRIEK FUNCTION                                         64380000
*                                                                       64440000
*              A!B IS DEFINED TO BE (!B)/(!A)*!B-A WITH SPECIAL         64500000
*              INTERPRETATION WHEN NEGATIVE INTEGERS OCCUR.             64560000
*                  IF EITHER A OR B IS NON-INTEGRAL (OR BOTH) THE       64620000
*              GAMMA FUNCTION IS USED TO COMPUTE A!B. IF ANY OF THE     64680000
*               ARGUMENTS ARE OUT OF THE DOMAIN OF MONADIC ! A          64740000
*              PRECALCULATION IS DONE TO AVOID OVERFLOW IF POSSIBLE.    64800000
*                  IF BOTH A AND B ARE INTEGERS THEN THERE ARE 3        64860000
*              REGIONS OF THE A,B LATTICE WHERE A!B IS NONZERO:         64920000
*               (1)  IF B>=A>=0 THE USUAL DEFINITION APPLIES,           64980000
*               (2)  IF A>0,B<0 THE DEFINITION IS GIVEN BY              65040000
*                  ((-1)**A)*A!A-B+1  (USING (1) ),                     65100000
*               (3)  IF A<=B<0 THE DEFINITION IS GIVEN BY               65160000
*                  ((-1)**A-B)*(-B+1)!-A+1 (USING (1) ).                65220000
*                                                                       65280000
         ENTRY EXBINOM                                                  65340000
         USING EXBINOM,10                                               65400000
         USING SHLOCAL,TLR                                              65460000
EXBINOM  LR    10,9                                                     65520000
         ST    LKR,BINSAVE                                              65580000
         MVI   BINFLAG,0           ZERO SIGN AND INTEGER FLAGS          65640000
         LDR   4,0                                                      65700000
         CD    4,BIBIGNO                                                65760000
         BNL   RNGERR              A TOO LARGE   DOMAIN ERROR           65820000
         AD    4,DMKFLOOR                                               65880000
         CDR   4,0                                                      65940000
         BNE   *+8                                                      66000000
         OI    BINFLAG,BININTA     A IS AN INTEGER                      66060000
         LDR   4,2                                                      66120000
         CD    4,BIBIGNO                                                66180000
         BNL   RNGERR              B TOO LARGE   DOMAIN ERROR           66240000
         AD    4,DMKFLOOR                                               66300000
         CDR   4,2                                                      66360000
         BNE   *+8                                                      66420000
         OI    BINFLAG,BININTB     B IS AN INTEGER                      66480000
         LDR   4,2                                                      66540000
         SDR   4,0                 C = B-A                              66600000
         TM    BINFLAG,BININTA+BININTB                                  66660000
         BO    BIBOTHI                                                  66720000
         BZ    BITESTC                                                  66780000
         TM    BINFLAG,BININTB                                          66840000
         BO    BIBINT                                                   66900000
         LTER  0,0                 ONLY A IS AN INTEGER                 66960000
         BNL   BINOI               IF POSITIVE IGNORE                   67020000
USE0     SDR   0,0                 IF NEGATIVE RESULT IS ZERO           67080000
         BR    LKR                                                      67140000
BIBINT   LTER  2,2                 ONLY B IS AN INTEGER                 67200000
         BNL   BINOI               IF POSITIVE IGNORE                   67260000
         B     RNGERR                                                   67320000
BIBOTHI  LDR   4,0                 A & B BOTH INTEGERS                  67380000
         MDR   4,2                                                      67440000
         LTER  4,4                                                      67500000
         BH    BIABP                                                    67560000
         BL    BIABN                                                    67620000
         LTER  0,0                                                      67680000
         BNZ   USE0                X SHRIEK 0 = 0                       67740000
         LD    0,ONE               0 SHRIEK X = 1                       67800000
         BR    LKR                                                      67860000
BIABN    LTER  0,0                 EITHER A OR B IS NEGATIVE            67920000
         BL    USE0                A NEGATIVE IMPLIES ZERO RESULT       67980000
         SDR   2,0                 B NEGATIVE IS MAPPED ONTO POSITIVE   68040000
*                                  QUADRANT EXCEPT FOR SIGN             68100000
         LCDR  2,2                                                      68160000
         SD    2,ONE               B = A-(B+1)                          68220000
         LDR   4,0                                                      68280000
BISSF    AW    4,DUNZERO           A ODD IMPLIES A NEGATIVE RESULT      68340000
         STD   4,BITEMP                                                 68400000
         TM    BITEMP+7,X'01'      LAST BIT ON ?                        68460000
         BZ    *+8                                                      68520000
         OI    BINFLAG,BISIGN                                           68580000
BIALLPI  LDR   4,2                 STANDARD CASE B>=A>=0  INTEGERS      68640000
         SDR   4,0                 B-A                                  68700000
         CDR   0,4                                                      68760000
         BL    *+6                                                      68820000
         LDR   4,0                 C = A MAX B-A                        68880000
         SDR   2,4                 B-C                                  68940000
         LD    0,ONE                                                    69000000
         SDR   6,6                                                      69060000
FACTOR   AD    4,ONE                                                    69120000
         AD    6,ONE                                                    69180000
         CDR   6,2                                                      69240000
         BH    SETSIGN                                                  69300000
         MDR   0,4                 MULTIPLY BY RATIOS                   69360000
         DDR   0,6                 (B-C+1)/1,(B-C+2)/2,...,B/(B-C)      69420000
         QUEND                                                          69480000
         B     FACTOR              PRODUCES AN EXACT INTEGER            69540000
SETSIGN  TM    BINFLAG,BISIGN                                           69600000
         BCR   8,LKR  BZR                                               69660000
         LCDR  0,0                 CHANGE SIGN IF NEEDED                69720000
         BR    LKR                                                      69780000
BIABP    LDR   4,2                 A TIMES B IS POSITIVE                69840000
         SDR   4,0                                                      69900000
         BL    USE0                RESULT IS ZERO IF A>B                69960000
         LTER  2,2                                                      70020000
         BNL   BIALLPI                                                  70080000
         AD    2,ONE               BOTH A & B ARE NEGATIVE INTEGERS     70140000
*                                  THE RESULT MAPS ONTO THE POSITIVE    70200000
*                                  QUADRANT EXCEPT FOR SIGN             70260000
         LCDR  6,2                                                      70320000
         AD    0,ONE                                                    70380000
         LCDR  2,0                 B = -(A+1)                           70440000
         LDR   0,6                 A = -(B+1)                           70500000
         B     BISSF               IF B-A IS ODD THEN RESULT IS NEG     70560000
BITESTC  LTER  4,4                 TEST IF C IS A NEGATIVE INTEGER      70620000
         BNL   BINOI                                                    70680000
         LDR   6,4                                                      70740000
         AD    6,DMKFLOOR                                               70800000
         CDR   4,6                                                      70860000
         BE    USE0                ZERO RESULT IF C NEG INTEGER         70920000
BINOI    CDR   4,0                 AT LEAST 1 NON-INTEGERAL ARGUMENT    70980000
*                                  WILL USE GAMMA FUNCTION              71040000
         BNL   *+6                                                      71100000
         LDR   4,0                 C = A MAX B-A                        71160000
         LD    0,ONE                                                    71220000
         LDR   6,2                                                      71280000
         CDR   6,4                                                      71340000
         BNL   *+6                                                      71400000
         LDR   6,4                 D = C MAX B                          71460000
AVOFLW   CD    6,FIFTY5                                                 71520000
         BL    CALLFACT                                                 71580000
         CD    6,BIDOMLIM                                               71640000
         BNL   RNGERR              D TOO LARGE   DOMAIN ERROR           71700000
         MDR   0,2                 GET PRODUCT OF RATIOS UNTIL D IS     71760000
         DDR   0,4                 WITHIN THE DOMAIN OF MONADIC !       71820000
         SD    6,ONE                                                    71880000
         SD    4,ONE                                                    71940000
         SD    2,ONE                                                    72000000
         QUEND                                                          72060000
         B     AVOFLW                                                   72120000
CALLFACT STD   0,BITEMP            E = PREVIOUS FACTOR                  72180000
         STD   2,BIRSAVE           B                                    72240000
         STD   4,BILSAVE           C                                    72300000
         LA    9,EXFACT                                                 72360000
*              WE ASSUME R10 NOT ALTERED BY EXFACT                      72420000
         LDR   2,4                                                      72480000
         BALR  LKR,9                                                    72540000
         LD    2,BIRSAVE           B                                    72600000
         SD    2,BILSAVE           B-C                                  72660000
         STD   0,BILSAVE           SHRIEK C                             72720000
         BALR  LKR,9                                                    72780000
         LD    2,BIRSAVE                                                72840000
         STD   0,BIRSAVE           SHRIEK B-C                           72900000
         BALR  LKR,9                                                    72960000
         DD    0,BILSAVE           (SHRIEK B)/SHRIEK C                  73020000
*                                  ORDER OF THIS COMPUTATION MINIMIZES  73080000
*                                   THE CHANCE OF OVERFLOW              73140000
         LD    2,BITEMP                                                 73200000
         DD    2,BIRSAVE                                                73260000
         MDR   0,2                                                      73320000
         L     LKR,BINSAVE                                              73380000
         LR    9,10                                                     73440000
         BR    LKR                                                      73500000
*                                                                       73560000
         DROP  10,TLR                                                   73620000
*                                                                       73680000
*                                  MASKS FOR BINFLAG                    73740000
*                                                                       73800000
BININTA  EQU   X'01'               A IS INTEGER                         73860000
BININTB  EQU   X'02'               B IS INTEGER                         73920000
BISIGN   EQU   X'04'                                                    73980000
         TITLE 'EXFACT     M O N A D I C       S H R I E K'             74040000
*                                                                       74100000
*        MONADIC SHRIEK FUNCTION                                        74160000
*                                                                       74220000
*              THE ARGUMENT IS SCALED BETWEEN 0 AND 1, COMPUTING THE    74280000
*              FACTORIAL.  IF POSATIVE INTEGER, RETURN FACTORIAL OF X.  74340000
*              IF NEGATIVE OR NON-INTEGER, COMPUTE GAMMA(X+1).          74400000
*                                                                       74460000
*              DOMAIN ERRORS WILL FALL OUT NATURALLY DURING CALCULATION 74520000
*                                                                       74580000
*              DYADIC SHRIEK ASSUMES R10 IS NOT ALTERED.                74640000
*                                                                       74700000
         ENTRY EXFACT                                                   74760000
         USING SHLOCAL,TLR         SCRATCH AREA ABOVE R14 IN M          74820000
         USING *,9                                                      74880000
EXFACT   LD    4,ONE                                                    74940000
         LDR   0,4                                                      75000000
         LTER  2,2                                                      75060000
         BCR   8,LKR BZR           IF SHRIEK 0, RESULT IS 1             75120000
         BM    EXFACT5             IF X NEGATIVE, SPECIAL HANDLING      75180000
         CDR   2,0                                                      75240000
         BCR   8,LKR BER           IF SHRIEK 1, RESULT IS 1             75300000
         BL    GAMMA               IF X LT 1, COMPUTE GAMMA X           75360000
         LDR   0,2                                                      75420000
         B     *+6                                                      75480000
EXFACT1  MDR   0,2                 SCALE UNTIL X IN RANGE 0 TO 1        75540000
         SDR   2,4                                                      75600000
         CDR   2,4                                                      75660000
         BH    EXFACT1                                                  75720000
         BCR   8,LKR BER           IF X INTEGER, RETURN FACTORIAL       75780000
         LDR   4,0                 SAVE REDUCTION FACTOR IN FR4         75840000
GAMMA    SD    2,HALF              COMPUTE GAMMA FUNCTION               75900000
         LD    0,GAMAA6            X IS IN (0,1). COMPUTE GAMMA X+1     75960000
         MDR   0,2                   BY MEANS OF MINIMAX FRACTION OF    76020000
         LD    6,GAMAB6              DEGREE (7,7) FOR Z IN (-0.5,0.5)   76080000
         ADR   6,2                                                      76140000
         LM    1,3,INDEX             Z(A0+A1*Z+A2*Z**2+...+A6*Z**6)     76200000
GAMALOOP AD    0,GAMAA5(1)      C0 + -------------------------------    76260000
         MDR   0,2                   B0+B1*Z+B2*Z**2+...+B6*Z**6+Z**7   76320000
         MDR   6,2                                                      76380000
         AD    6,GAMAB5(1)                                              76440000
         BXLE  1,2,GAMALOOP                                             76500000
         DDR   0,6                                                      76560000
         AD    0,GAMAC0                                                 76620000
         MDR   0,4                                                      76680000
         BR    LKR                 RETURN TO OPCONTROL                  76740000
*                                                                       76800000
EXFACT5  ADR   2,4                 NEGATIVE ARGUMENT                    76860000
         MDR   0,2                 INCREASE ARG BY USING RELATION       76920000
         LTER  2,2                 !X-1 = (!X)/!X                       76980000
         BM    EXFACT5                                                  77040000
         BZ    RNGERR                                                   77100000
         DDR   4,0                                                      77160000
         B     GAMMA                                                    77220000
*                                                                       77280000
         DROP  9                                                        77340000
 TITLE '            R N G E R R      A N D      C O N S T A N T S'      77400000
RNGERR   BALR  9,0                 ESTABLISH ADDRESSABILITY             77460000
         USING *,9                                                      77520000
         LA    1,ERANGE            DOMAIN ERROR                         77580000
         ICALL ERROR                                                    77640000
         DROP  9                                                        77700000
*                                                                       77760000
*                                                                       77820000
         LTORG                                                          77880000
*                                                                       77940000
*                                                                       78000000
*              CONSTANTS  FOR  ATANH  &  ASINH                          78060000
*                                                                       78120000
         DC    0D'0'                                                    78180000
ATANHC0  DC    X'413227B4C470D956'     15*16*4/49*9*25                  78240000
ATANHC1  DC    X'4114500000000000'     13*9*25/36*16*4                  78300000
ATANHC2  DC    X'41320FEDCBA98765'     11*16*4/9*25                     78360000
ATANHC3  DC    X'4114400000000000'     9*9/16*4                         78420000
ATANHC4  DC    X'4131C71C71C71C71'     7*4/9                            78480000
ATANHC5  DC    X'4114000000000000'     5/4                              78540000
ATANHC6  DC    X'4130000000000000'     3                                78600000
ATANHC9  DC    D'0.169'                                                 78660000
*                                                                       78720000
*              CONSTANTS  FOR  ATAN                                     78780000
*                                                                       78840000
         DC    0D'0'                                                    78900000
ATANC1   DC    X'BF1E31FF1784B965'    -0.7371899082768562E-2            78960000
ATANC2   DC    X'C0ACDB34C0D1B35D'    -0.6752198191404210               79020000
ATANC3   DC    X'412B7CE45AF5C165'     0.2717991214096480E+1            79080000
ATANC4   DC    X'C11A8F923B178C78'    -0.1660051565960002E+1            79140000
ATANC5   DC    X'412AB4FD5D433FF6'     0.2669186939532663E+1            79200000
ATANC6   DC    X'C02298BB68CFD869'    -0.1351430064094942               79260000
ATANC7   DC    X'41154CEE8B70CA99'     0.1331282181443987E+1            79320000
RT3M1    DC    X'40BB67AE8584CAA8'     SQRT(3)-1                        79380000
*                                                                       79440000
*              CONSTANTS  FOR  SIN  &  COS                              79500000
*                                                                       79560000
COSC7    DC    X'B66C992E84B6AA37'     COS C7                           79620000
         DC    X'3778FCE0E5AD1685'     SIN C6                           79680000
COSC6    DC    X'387E731045017594'     COS C6                           79740000
         DC    X'B978C01C6BEF8CB3'     SIN C5                           79800000
COSC5    DC    X'BA69B47B1E41AEF6'     COS C5                           79860000
         DC    X'3B541E0BF684B527'     SIN C4                           79920000
COSC4    DC    X'3C3C3EA0D06ABC29'     COS C4                           79980000
         DC    X'BD265A599C5CB632'     SIN C3                           80040000
COSC3    DC    X'BE155D3C7E3C90F8'     COS C3                           80100000
         DC    X'3EA335E33BAC3FBD'     SIN C2                           80160000
COSC2    DC    X'3F40F07C206D6AB1'     COS C2                           80220000
         DC    X'C014ABBCE625BE41'     SIN C1                           80280000
COSC1    DC    X'C04EF4F326F91777'     COS C1 -2F                       80340000
PIOV4    DC    X'40C90FDAA22168C2'     SIN C0                           80400000
DUNZERO  DC    X'4E00000000000000'                                      80460000
         DC    0D'0'                                                    80520000
UNFLO    DC    X'3A100000'                                              80580000
MAX      DC    X'4DC90FDA'                                              80640000
         AIF   (NOT &HIPREC).HIPREC0                                    80700000
*                                                                       80760000
*              CONSTANTS FOR TAN                                        80820000
*                                                                       80880000
         DS    0D                                                       80940000
TANA2    DC    X'C325FD4A87357CAF' -   607.8306953515                   81000000
TANA1    DC    X'44AFFA6393159226' + 4505093889630777                   81060000
TANA0    DC    X'C58AFDD0A41992D4' -569309.0400634512  +3F IN ABS       81120000
TANB3    DC    X'422376F171F72282' +    35.4646216610                   81180000
TANB2    DC    X'C41926DBBB1F469B' -  6438.8583240077                   81240000
TANB1    DC    X'4532644B1E45A133' +206404.6948906228                   81300000
TANB0    DC    X'C5B0F82C871A3B68' -724866.7829840012                   81360000
.HIPREC0 ANOP                                                           81420000
*                                                                       81480000
*              CONSTANTS FOR SINH AND COSH                              81540000
*                                                                       81600000
         DC    0D'0'                                                    81660000
COSHC6   DC    X'38B2D4C184418A97'     0.1626459177981471(-9)           81720000
COSHC5   DC    X'3A6B96B897BA1636'     0.2504995887597646(-7)           81780000
COSHC4   DC    X'3C2E3BC881345D91'     0.2755733025610683(-5)           81840000
COSHC3   DC    X'3DD00D00CB06A6F5'     0.1984126981270711(-3)           81900000
COSHC2   DC    X'3F2222222222BACE'     0.8333333333367232(-2)           81960000
COSHC1   DC    X'402AAAAAAAAAAA4D'     0.1666666666666653 +2F           82020000
VSQ      DC    X'403FDF9434F03D26'     0.2495052937740537 = V**2        82080000
LNV      DC    X'C0B1B30000000000'    -0.6941375732421875 = LOG(V)      82140000
DELTA    DC    X'3E40F0434B741C6D'     0.0009908832830238 = 1/2V-1+F    82200000
MAXI     DC    X'42AF5DC0'             175.366                          82260000
LIMIT    DC    X'40E1A1B8'             0.881374                         82320000
*                                                                       82380000
*              CONSTANTS  FOR  TANH                                     82440000
*                                                                       82500000
         DC    0D'0'                                                    82560000
         AIF   (&HIPREC EQ 0).HIPREC3                                   82620000
TANHC0   DC    X'C0F6E12F40F5590A'    -0.9643735440816707               82680000
TANHC1   DC    X'419DA5D6FD3DBC84'     0.9852988232825539E+1            82740000
TANHC2   DC    X'C31C504FEF537AF6'    -0.4530195153485250E+3            82800000
TANHC3   DC    X'424D2FA31CAD8D00'     0.7718608264195518E+2            82860000
TANHC4   DC    X'C3136E2A5891D8E9'    -0.3108853383729134E+3            82920000
TANHC5   DC    X'4219B3ACA4C6E790'     0.25701850308319156E+2           82980000
MLIM     DC    X'408C9F95'                                              83040000
HLIM     DC    X'421419DB'                                              83100000
         AGO   .HIPREC4                                                 83160000
.HIPREC3 ANOP                                                           83220000
TANHC18  DC    D'18.36840028483855'                                     83280000
.HIPREC4 ANOP                                                           83340000
*                                                                       83400000
*              CONSTANTS FOR ASIN AND ACOS                              83460000
*                                                                       83520000
         DC    0D'0'                                                    83580000
ACOSC1   DC    X'3F180CD96B42A610'     0.00587162904063511              83640000
ACOSD1   DC    X'C07FE6DD798CBF27'    -0.49961647241138661              83700000
ACOSC2   DC    X'C1470EC5E7C7075C'    -4.44110670602864049              83760000
ACOSD2   DC    X'C1489A752C6A6B54'    -4.53770940160639666              83820000
ACOSC3   DC    X'C13A5496A02A788D'    -3.64565146031194167              83880000
ACOSD3   DC    X'C06B411D9ED01722'    -0.41896233680025977              83940000
ACOSC4   DC    X'C11BFB2E6EB617AA'    -1.74882357832528117              84000000
ACOSD4   DC    X'BF99119272C87E78'    -0.03737027365107758              84060000
ACOSC5   DC    X'C11323D9C96F1661'    -1.19625261960154476              84120000
PO2M1    DC    X'40921FB54442D184'     PI/2 - 1.0                       84180000
PI       DC    X'413243F6A8885A30'     PI   -F                          84240000
TAN15    DC    X'40449851'                                              84300000
*                                                                       84360000
*              MISC CONSTANTS                                           84420000
*                                                                       84480000
LARGINT  DC    F'1534'             CONSTANT FOR EXEXP                   84540000
K8E16    DC    D'8E16'             SIGNIFICANCE TEST FOR 4,-4 CIRC 5988 84600000
CNVTFUZZ DC    X'353FF00000000000'  NORMALIZED FUZZ, WE ONLY NEED ABS   84660000
*                                  FUZZ FOR LEFT ARG OF CIRCLE          84720000
TABLE    DC    X'0303020201010101' THESE 4 CONSTANTS MUST BE TOGETHER   84780000
ZERO     DC    X'0000000000000000' THESE 4 CONSTANTS MUST BE TOGETHER   84840000
HALF     DC    X'4080000000000000' THESE 4 CONSTANTS MUST BE TOGETHER   84900000
*        DC    X'4110000000000000' THESE 4 CONSTANTS MUST BE TOGETHER   84960000
ONE      DC    X'4110000000000000'             THESE                    85020000
RT3      DC    X'411BB67AE8584CAB'     SQRT(3)   SIX                    85080000
ATANQQ   DC    X'0000000000000000'     0           CONSTANTS            85140000
         DC    X'40860A91C16B9B2C'     PI/6          MUST               85200000
         DC    X'C0921FB54442D184'     -PI/2+1         BE               85260000
         DC    X'BFC152382D736574'     -PI/3-F)+1        CONSECUTIVE    85320000
TWO      DC    X'4120000000000000'     2.0                              85380000
         DC    0F'0'                                                    85440000
TANUNFLO DC    X'35400000'         2**-46                               85500000
*                                                                       85560000
*              CONSTANTS FOR SQRT                                       85620000
*                                                                       85680000
         DC    0F'0'                                                    85740000
BIAS     DC    X'31000000'                                              85800000
SQRTBBBB DC    X'00423A2A'         0.2587, TARGET CHAR -8 TO BE AFFIXED 85860000
SQRTA    DC    X'48385F07'         092202*16**8                         85920000
*                                                                       85980000
*              CONSTANTS FOR DYADIC EXPONENTIATION                      86040000
*                                                                       86100000
         DC    D'0'                                                     86160000
RELERR   DC    X'4000000000000010'                                      86220000
*                                                                       86280000
*              CONSTANTS FOR MONADIC EXPONENTIAL                        86340000
*                                                                       86400000
         DC    0D'0'                                                    86460000
LOGE2    DC    X'40B17217F7D1CF79' LOG 2(BE) TRUNCATED                  86520000
ONO16    DC    X'4010000000000000'                                      86580000
MEXPSCAL DC    X'45000000'                                              86640000
MEXPC6   DC    X'3D9E0F1E'         .1507368551403575E-3                 86700000
MEXPC5   DC    X'3E575D42BB7276D4' .1333073417706260E-2                 86760000
MEXPC4   DC    X'3F276553A5F9BC94' .9618117095313700E-2                 86820000
MEXPC3   DC    X'3FE35846A61AEE7A' .5550410840231345E-1                 86880000
MEXPC2   DC    X'403D7F7BFF0289DE' .2402265069563678                    86940000
MEXPC1   DC    X'40B17217F7D1CC79' .6931471805599346                    87000000
MCONST   DC    X'40F5257D152486CC'     2**(-1/16)                       87060000
         DC    X'40EAC0C6E7DD2439'     2**(-2/16)                       87120000
         DC    X'40E0CCDEEC2A94E1'     2**(-3/16)                       87180000
         DC    X'40D744FCCAD69D6B'     2**(-4/16)                       87240000
         DC    X'40CE248C151F8481'     2**(-5/16)                       87300000
         DC    X'40C5672A115506DB'     2**(-6/16)                       87360000
         DC    X'40BD08A39F580C37'     2**(-7/16)                       87420000
         DC    X'40B504F333F9DE65'     2**(-8/16)                       87480000
         DC    X'40AD583EEA42A14B'     2**(-9/16)                       87540000
         DC    X'40A5FED6A9B15139'     2**(-10/16)                      87600000
         DC    X'409EF5326091A112'     2**(-11/16)                      87660000
         DC    X'409837F0518DB8A9'     2**(-12/16)                      87720000
         DC    X'4091C3D373AB11C3'     2**(-13/16)                      87780000
         DC    X'408B95C1E3EA8BD7'     2**(-14/16)                      87840000
         DC    X'4085AAC367CC487B'     2**(-15/16)                      87900000
MEXPMAX  DC    X'42AEAC4E'         174.6731                             87960000
MEXPMIN  DC    X'C2B437DF'         -180.2187                            88020000
*                                                                       88080000
*              CONSTANTS FOR DYADIC LOGARITHM                           88140000
*                                                                       88200000
         DC    0D'0'                                                    88260000
LOGTWO   DC    X'40B17217F7D1CF7A'     LOG 2                            88320000
LOGTEN   DC    X'4124D763776AAA2B'     LOG 10                           88380000
TEN      DC    X'41A0000000000000'     10.0                             88440000
*                                                                       88500000
*              CONSTANTS FOR MONADIC LOGARITHM                          88560000
*                                                                       88620000
         DC    0D'0'                                                    88680000
IPSTART  DC    X'4600000000000000'                                      88740000
MLOGE2   DC    X'40B17217F7D1CF7B' LOG 2 (BASE E) + 1 IN LAST DIGIT     88800000
MLOGC7   DC    X'4025E9B17CA9B973'     .1480971268990510                88860000
MLOGC6   DC    X'40273337E26DBA7F'     .1531252792171731                88920000
MLOGC5   DC    X'402E8CD32A425C06'     .1818363168880382                88980000
MLOGC4   DC    X'4038E38A00083F6B'     .2222219705656678                89040000
MLOGC3   DC    X'4049249251450212'     .2857142876064318                89100000
MLOGC2   DC    X'40666666665EBAA3'     .3999999999930233                89160000
MLOGC1   DC    X'40AAAAAAAAAAAD6C'     .666666666666764                 89220000
         DC    0E'0'                                                    89280000
MLOGLIM  DC    X'40B504F3'         1/SQRT 2                             89340000
*                                                                       89400000
*              CONSTANTS FOR MONADIC SHRIEK                             89460000
*                                                                       89520000
INDEX    DC    F'0'                (1)  THESE 3 WORDS MUST BE TOGETHER  89580000
         DC    F'8'                (2)  THESE 3 WORDS MUST BE TOGETHER  89640000
         DC    F'40'               (3)  THESE 3 WORDS MUST BE TOGETHER  89700000
         DC    0D'0'                                                    89760000
GAMAA6   DC    X'C0C1B71B59A1A1F6'   A6 = -   0.7567002385928           89820000
GAMAA5   DC    X'41B33F20CFA73CB3'   A5 =    11.2029121505218           89880000
         DC    X'4153CF867C239860'   A4 =     5.2381653641874           89940000
         DC    X'C23EBA40FFB0397B'   A3 = -  62.7275543027149           90000000
         DC    X'43441182D7048BE6'   A2 =  1089.0944433381650           90060000
         DC    X'43C3CDE7AC8F2232'   A1 =  3132.8690610495717   -3F     90120000
         DC    X'42E8A532ACC72020'   A0 =   232.6453044878145           90180000
GAMAB6   DC    X'C1A5004D879829C5'   B6 = -  10.3125739380508           90240000
GAMAB5   DC    X'41E62A3573ECF95D'   B5 =    14.3853048828456           90300000
         DC    X'42C97F1D84DC37A0'   B4 =   201.4965441739693           90360000
         DC    X'C327558408F56C71'   B3 = - 629.3447351061687           90420000
         DC    X'C358DA535E278586'   B2 = -1421.6453534644901           90480000
         DC    X'4411F52476FDA8AB'   B1 =  4597.1424406563556           90540000
         DC    X'441C1A16BED21CC5'   B0 =  7194.0888491935961           90600000
GAMAC0   DC    X'40E2DFC48DA77B56'   GAMMA(1.5) = 0.8862269254527580 +F 90660000
*                                                                       90720000
*              CONSTANTS FOR DYADIC SHRIEK                              90780000
*                                                                       90840000
         DC    0D'0'                                                    90900000
DMKFLOOR DC    X'4F00000000000000'                                      90960000
FIFTY5   DC    D'55.0'                                                  91020000
BIBIGNO  DC    X'4E80000000000000'                                      91080000
BIDOMLIM DC    D'1.0E5'                                                 91140000
*                                                                       91200000
*                                                                       91260000
*              SCRATCH AREA FOR DYADIC CIRCLE, SQUARE ROOT,             91320000
*                  MONADIC & DYADIC EXP, MONADIC & DYADIC LOG           91380000
*              ASSUMPTIONS ARE MADE ABOUT ORDERING                      91440000
*                                                                       91500000
LOCAL    DSECT ,                   ************************************ 91560000
BUFFQ    DS    D                   **  THESE LOCATIONS ARE USED BY      91620000
         ORG   BUFFQ+4             **  MEXP, MLOG, & SQRT.  THEY        91680000
FIELDS   DS    F                   **  THEREFORE SHOULD BE USED ONLY    91740000
SQRTB    DS    F                   **  WITH CAUTION BY ROUTINES WHICH   91800000
         ORG   SQRTB               **  CALL ANY OF THEM.                91860000
IPART    DS    D                   **                                   91920000
*                                  ************************************ 91980000
*                                                                       92040000
*                                  THE FOLLOWING SHOULD NOT BE USED     92100000
*                                  BY MEXP, MLOG, OR SQRT.              92160000
*                                                                       92220000
BUFF     DS    D                   CIRCLE PUTS ARG HERE INITIALLY       92280000
BUFF2    DS    D                                                        92340000
SWITCH   DS    0CL1                SWITCH FOR ASIN  &  ACOS             92400000
SAVELKR  DS    F                   SAVE AREA FOR LINK REGISTER          92460000
SAVELKR2 DS    F                   SLOT FOR LKR WITHIN SINH & COSH      92520000
A        DS    D                   SLOT FOR DYADIC EXP                  92580000
B        DS    D                   SLOT FOR DYADIC EXP                  92640000
DSTORE   DS    D                   SLOT FOR DYADIC EXP                  92700000
FTEMP    DS    F                   SLOT FOR DYADIC EXP                  92760000
RESSIGN  DS    X                   SWITCH FOR DYADIC EXP                92820000
*                                                                       92880000
*                                                                       92940000
*              SCRATCH AREA FOR DYADIC SHRIEK & MONADIC SHRIEK          93000000
*                                                                       93060000
SHLOCAL  DSECT                                                          93120000
SHBUFF   DS    D                   MONADIC SHRIEK BUFFER                93180000
BILSAVE  DS    D                                                        93240000
BIRSAVE  DS    D                                                        93300000
BINSAVE  DS    D                                                        93360000
BITEMP   DS    D                                                        93420000
BINFLAG  DS    X                                                        93480000
*                                                                       93540000
*                                                                       93600000
*                                                                       93660000
         END                                                            93720000
./  ADD    NAME=APLSMTRA
MTRA     TITLE 'M O N A D I C   T R A N S P O S E             05/11/70' 00920000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  01840000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02760000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03680000
EXMTRAN  CSECT                                                          04600000
         PRINT OFF       APLDEFN, OPSECT                                05520000
         COPY  APLDEFN                                                  07360000
         COPY  OPSECT                                                   08280000
         PRINT ON,NOGEN                                                 09200000
OPSECT   DSECT                                                          10120000
         ORG   BINOSAVE                                                 11040000
ROOSAV   DS    F                                                        11960000
SINCR    DS    3F                                                       12880000
RX       DS    3F                                                       13800000
RR       DS    3F                                                       14720000
         ORG                                                            15640000
         TITLE 'M O N A D I C   T R A N S P O S E             05/11/70' 16560000
         EXTRN OPSPACE                                                  17480000
         EXTRN STORE                                                    18400000
         EXTRN FETCH                                                    19320000
EXMTRAN  CSECT                                                          20240000
         USING OPSECT-16,LR                                             21160000
         USING *,9                                                      22080000
         L     2,RHRANK           RANK LSS 2 MEANS DO NOTHING           23000000
         LA    7,8                R7  AN 8                              23920000
         CR    2,7                                                      24840000
         BNL   STOR                                                     25760000
         MVI   TEMPRGT,0          VECTOR OR SCALAR ARGUMENT             26680000
         L     0,SVI              RETURN ARGUMENT AS RESULT.            27600000
         A     0,INCR                                                   28520000
         S     0,=F'4'                                                  29440000
         ST    0,SVI                                                    30360000
         SR    0,0                                                      31280000
         ST    0,INCR                                                   32200000
         BR    LKR                                                      33120000
STOR     ST    LKR,ROOSAV                                               34040000
         L     1,RHXRHO                                                 34960000
         L     3,RHTYPE                                                 35880000
         LR    5,2                R5  RANK                              36800000
         LR    6,3                R6  TYPE                              37720000
         L     10,=A(OPSPACE)     GET SPACE FOR RESULT                  38640000
         BALR  LKR,10                                                   39560000
         STH   5,MRANK(1)         R1  BASE                              40480000
         STC   6,MTYPE(1)                                               41400000
         LA    0,MRHO-M(5,1)      R0  RESORG                            42320000
         ST    0,RESORG                                                 43240000
         L     4,RHBASE           R4  RHBASE                            44160000
         LA    2,MRHO-M(5,4)      R2  RHORG                             45080000
         ST    2,RHORG                                                  46000000
         S     5,=F'5'            4+1                                   46920000
         AR    1,MR                                                     47840000
         AR    4,MR                                                     48760000
         EX    5,MOVE             MVC MRHO-M(0,1),MRHO-M(4)             49680000
         L     8,MRHO-M-3(5,4)    PENULT DIM OF ARG                     50600000
*  ERROR ON PREVIOUS STATEMENT IS HARMLESS **************************** 51520000
         ST    8,RR+4                                                   52440000
         L     7,MRHO-M+1(5,4)    LAST DIM OF ARGUMENT                  53360000
*  ERROR ON PREVIOUS STATEMENT IS HARMLESS **************************** 54280000
         ST    7,RR+8                                                   55200000
         ST    7,MRHO-M-3(5,1)    R7  PENULT DIM OF RESULT              56120000
*  ERROR ON PREVIOUS STATEMENT IS HARMLESS **************************** 57040000
         ST    8,MRHO-M+1(5,1)    R8  LAST DIM OF RESULT                57960000
*  ERROR ON PREVIOUS STATEMENT IS HARMLESS **************************** 58880000
         ST    8,SINCR+8          ALSO DISTANCE TWIXT ELEMS OF A COLUM  59800000
         MR    6,8                R7  X/LAST 2 DIMS                     60720000
         L     1,RHXRHO                                                 61640000
         LTR   1,1                                                      62560000
         BZ    ENDTRAN                                                  63480000
         SR    0,0                                                      64400000
         ST    0,RX               CLEAR RX                              65320000
         MVC   RX+4(8),RX                                               66240000
         DR    0,7                                                      67160000
         ST    1,RR                                                     68080000
         SR    7,8                                                      69000000
         LA    0,1                                                      69920000
         ST    0,SINCR                                                  70840000
         SR    0,7                                                      71760000
         ST    0,SINCR+4                                                72680000
         L     3,RHTYPE                                                 73600000
         SR    5,5                R5  INDEX IN RESULT                   74520000
         SR    6,6                R6  INDEX IN ARGUMENT                 75440000
         L     8,RHORG            IDLE REGISTERS ARE THE DEVIL'S        76360000
TRANSFER LR    2,6                     PLAYGROUND                       77280000
         LR    4,8                                                      78200000
         ICALL FETCH                                                    79120000
         LR    2,5                                                      80040000
         L     4,RESORG                                                 80960000
         ICALL STORE                                                    81880000
         LA    6,1(6)             INCREMENT SX                          82800000
         LA    10,8                                                     83720000
INCRX    L     7,RX(10)           INCREMENT RX                          84640000
         LA    7,1(7)                                                   85560000
         C     7,RR(10)                                                 86480000
         BL    INCREX                                                   87400000
         SR    7,7                                                      88320000
         ST    7,RX(10)                                                 89240000
         S     10,=F'4'                                                 90160000
         BNL   INCRX                                                    91080000
ENDTRAN  L     LKR,ROOSAV                                               92000000
         BR    LKR                                                      92920000
INCREX   ST    7,RX(10)                                                 93840000
         A     5,SINCR(10)                                              94760000
         QUEND                                                          95680000
         B     TRANSFER                                                 96600000
MOVE     MVC   MRHO-M(0,1),MRHO-M(4)                                    97520000
         END                                                            98440000
./  ADD    NAME=APLSMVT1
MVT1     TITLE 'APL 360-OS MVT   R E S I D E N T  S V C S'              01350000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02700000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       04050000
         SPACE 3                                                        05400000
IGCINIT  CSECT                                                          06750000
CVTDCB   EQU   X'74'                                                    08100000
CVTBTERM EQU   X'34'                                                    09450000
TCBUSER  EQU   X'A8'                                                    10800000
TCBOTC   EQU   X'84'                                                    12150000
TCBJSTCB EQU   X'7C'                                                    13500000
SVCOPSW  EQU   X'20'                                                    14850000
SVCNPSW  EQU   X'60'                                                    16200000
DCBDEBAD EQU   44                                                       17550000
DEBDVMOD EQU   32                                                       18900000
DEBDCBAD EQU   24                                                       20250000
         SPACE 3                                                        21600000
         BALR  9,0                                                      22950000
         USING *,9                                                      24300000
         CLI   CVTDCB(3),X'10'     IS THIS MVT?                         25650000
         BNE   IGCFAIL             KILL IT HERE.                        27000000
         LTR   2,0                                                      28350000
         BNZ   IGCFMSK                                                  29700000
         L     5,SAVP44                                                 31050000
         L     6,8(1)                                                   32400000
         CLC   0(4,5),0(6)                                              33750000
         BNE   IGCFAIL                                                  35100000
IGCST    ST    1,TCBUSER(4)                                             36450000
         L     5,TCBOTC(4)                                              37800000
         C     5,TCBJSTCB(4)                                            39150000
         BNE   IGCFAIL APL HAS A TWO TASK STRUCTURE                     40500000
         ST    1,TCBUSER(5)                                             41850000
         BR    14                                                       43200000
         SPACE 3                                                        44550000
IGCFMSK  X     0,DEBDCBAD(1)                                            45900000
         N     0,=A(X'FFFFFF')                                          47250000
         BNZ   IGCFAIL                                                  48600000
         LR    0,1                                                      49950000
         X     0,DCBDEBAD(2)                                            51300000
         N     0,=A(X'FFFFFF')                                          52650000
         BNZ   IGCFAIL                                                  54000000
         MVI   DEBDVMOD(1),0                                            55350000
         BR    14                                                       56700000
         DROP  9                                                        58050000
         SPACE 3                                                        59400000
         ENTRY IGCMAP                                                   60750000
IGCMAP   BALR  9,0                                                      62100000
         USING *,9                                                      63450000
         L     5,SAVP44                                                 64800000
         L     2,TCBUSER(4)                                             66150000
         LM    6,8,0(2)                                                 67500000
         CLC   0(4,5),0(8)                                              68850000
         BNE   IGCFAIL                                                  70200000
         MVC   0(8,6),SVCOPSW                                           71550000
         ST    7,SVCOPSW+4                                              72900000
         NC    SVCOPSW(4),SVCNPSW                                       74250000
         BR    14                                                       75600000
         DROP 9                                                         76950000
         SPACE 3                                                        78300000
*  THIS IS AN INVALID CALL TO THE APL SVC'S                             79650000
*        THE CALLING TASK WILL BE TERMINATED                            81000000
*          WITH A S-FXX ABEND, WHERE XX IS THE SVC NUMBER               82350000
*                                                                       83700000
IGCFAIL  LR    0,4       ADDRESS OF TCB TO BE TERMINATED                85050000
         LA    1,X'F00'                                                 86400000
         IC    1,SVCOPSW+3    GET SVC CODE                              87750000
         SLL   1,12                                                     89100000
         L     15,CVTBTERM(3)                                           90450000
         BR    15                                                       91800000
         SPACE 3                                                        93150000
         EXTRN IEASCSAV                                                 94500000
SAVP44   DC    A(IEASCSAV+44)                                           95850000
         LTORG                                                          97200000
         END                                                            98550000
./  ADD    NAME=APLSOCTL
OCTL     TITLE 'O P E R A T O R   C O N T R O L               05/11/70' 00090000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00180000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00270000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00360000
         MACRO                                                          00450000
&L       FETCHES &R2,&R3,&R4,&R5                                        00540000
         DC    A(&R2,&R3,&R4,&R5)                                       00630000
         MEND                                                           00720000
         SPACE                                                          00810000
         PRINT OFF       APLDEFN                                        00990000
OPEXEC   CSECT                                                          01080000
         COPY  APLDEFN                                                  01170000
         PRINT ON,NOGEN                                                 01260000
         COPY  OPSECT                                                   01350000
         TITLE 'O P E R A T O R   C O N T R O L               05/11/70' 01440000
OPEXEC   CSECT                                                          01530000
*                                                                       01620000
*        EXECUTION ROUTINE CALLING CONVENTIONS.                         01710000
*                                                                       01800000
*                                                                       01890000
*              THE FOLLOWING VALUES ARE ALWAYS CALCULATED PRIOR TO      01980000
*              OPERATOR CALL BY OPEXEC:                                 02070000
*                                                                       02160000
*              OPERATOR,  OPINDEX                                       02250000
*              TYPINFO:  OPRN,  LCTYPE,  RCTYPE,  RSTYPE,  COMTYP       02340000
*                                  (ARTHTP RESULTS)                     02430000
*                                                                       02520000
*              INCR                                                     02610000
*              TEMPRGT,  TEMPLFT   1  INDICATES TEMP.                   02700000
*              LHSCALAR,  RHSCALAR 1  INDICATES SCALAR                  02790000
*              BLOWN               1  INDICATES BLOWUP RECOVERY IN PROG 02880000
*                                     RESS.                             02970000
*              TEMPIND             1  INDICATES TEMP INDEX.             03060000
*                                                                       03150000
*              LHBASE,  LHRANK,  LHXRHO,  LHTYPE                        03240000
*              RHBASE,  RHRANK, RHXRHO,  RHTYPE                         03330000
*              INDBASE,  INDRANK,  INDXRHO,  INDTYPE                    03420000
*              IF INDXRHO = 1, INDEX, ADJUSTED BY IORIGIN.              03510000
*              IF INDXRHO NOT = 1, CONTENTS ARE MEANINGLESS.            03600000
*        INDBASE IS SET TO 0 FOR ELIDED OPERATOR INDEX OR 1 IF          03690000
*        AN OPERATOR INDEX EXISTS.  (UPPER BYTE)                        03780000
*                                                                       03870000
*                                                                       03960000
*        CALLING SEQUENCE IS:                                           04050000
*                                                                       04140000
*              L       9,EXECUTION ROUTINE ADDRESS.                     04230000
*              BALR    LKR,9                                            04320000
*                                                                       04410000
*                                                                       04500000
*        REGISTERS IN USE.                                              04590000
*                                                                       04680000
*           1. SCALAR OPERATORS..                                       04770000
*              R1  OR  F0          LEFT OPERAND                         04860000
*              R2  OR  F2          RIGHT OPERAND                        04950000
*              --RESULT TO BE RETURNED IN R1 OR F0.                     05040000
*              R0  TO  R4          MAY OTHERWISE BE USED AS SCRATCH     05130000
*              R5 TO R6            MUST BE PRESERVED.                   05220000
*              R7                  STORE ROUTINE ADDRESS, MUST BE       05310000
*                                    PRESERVED.                         05400000
*              R8                  MAIN LOOP LOOP COUNT, MUST BE        05490000
*                                    PRESERVED                          05580000
*              R9                  EXECUTION ROUTINE ADDRESS, MUST      05670000
*                                    BE PRESERVED.                      05760000
*              R10                 UNUSED.                              05850000
*              R11                 BASE REG FOR M-ARRAY, MUST BE        05940000
*                                    PRESERVED.                         06030000
*              R12                 BASE REG FOR PROGRAM, MUST BE        06120000
*                                    PRESERVED.                         06210000
*              R13                 BASE REG FOR LOCAL VARIABLES,        06300000
*                                    MUST BE PRESERVED.                 06390000
*              R14                 TOP OF SPACE NEEDED FOR LOCAL        06480000
*                                    VARIABLES, MUST BE PRESERVED.      06570000
*              R15                 LINK REG,  MUST BE PRESERVED.        06660000
*              F0 TO F6            MAY OTHERWISE BE USED AS SCRATCH.    06750000
*                                                                       06840000
*                                                                       06930000
*           2. NON-SCALAR OPERATORS.                                    07020000
*                                                                       07110000
*              R11 TO R15          MUST BE PRESERVED.                   07200000
*              ALL OTHERS          MAY BE USED AS SCRATCH.              07290000
*                                                                       07380000
*              NON SCALAR OPERATORS MUST GET THEIR OWN SPACE.  SEE      07470000
*              OPSPACE SECTION,  THIS LISTING                           07560000
*                                                                       07650000
*                                                                       07740000
         EJECT                                                          07830000
*                                                                       07920000
*********************************************************************** 08010000
*                                                                       08100000
*        OPERATOR EXECUTION CONTROL.                                    08190000
*                                                                       08280000
*********************************************************************** 08370000
*                                                                       08460000
DODOP    PROLOG OPSECT,NDOPSECT                                         08550000
         ENTRY DODOP                                                    08640000
         EXTRN MATRIX                                                   08730000
         EXTRN REDUCE                                                   08820000
*        ON ENTRY, SVI POINTS TO NEXT AVAILABLE STACK ENTRY.            08910000
*                                                                       09000000
         L     9,SVI               SO WE NEED IT.                       09090000
         AR    9,MR                ABSOLUTE POINTER IN 9.               09180000
         LM    15,1,8(9)           OPERATOR AND RIGHT HAND BASE.        09270000
         LA    5,16                LOAD INCREMENT FOR SVI.              09360000
         ST    5,INCR              STORE THE INCREMENT.                 09450000
         STM   15,0,OPERATOR       SAVE OPERATOR AND ITS INDEX          09540000
*                                                                       09630000
*        FIRST, FIND OUT WHAT OPERANDS LOOK LIKE.                       09720000
*                                                                       09810000
         LA    LKR,LJWSEND         SET UP EXIT FROM SETUP ROUTINE.      09900000
LJWSET   LM    2,7,LJWSCONS        LISTBIT, 1, STRIKE, -4, ONE, ZERO.   09990000
         LR    8,3                 GET THE ONE IN R8, TO FLAG TEMPORARY 10080000
         BXH   1,7,LJWS1           BRANCH IF TIS NOT NAMED              10170000
         LR    8,7                 MAKE IT ZERO, IT IS NAMED.           10260000
         L     1,M(1)              GET THE SYMBOL TABLE POINTER.        10440000
LJWS1    NR    1,4                 STRIKE THE HIGH ORDER 8 BITS.        10530000
         BC    8,VALERR            IF IT IS ZERO IT IS NOT DEFINED.     10620000
         AR    1,MR                MAKE IT ABSOLUTELY ADDRESSABLE.      10710000
         N     2,MLIST-M(1)        SEE IF IT IS THE FORBIDDEN LIST.     10800000
         BC    7,SYNTERR           TOO BAD IF IT IS                 G01 10890000
         LH    4,MRANK-M(1)        GET NUMBER OF DIMENSIONS.            10980000
         BXLE  4,5,LJWS3           BRANCH IF IT IS SCALAR.              11070000
         L     3,MRHO-M(1,4)       LOAD THE LAST DIMENSION LENGTH.      11160000
         BXLE  4,5,LJWS3           SKIP MULTIPLY IF ONLY ONE DIM.       11250000
LJWS2    M     2,MRHO-M(1,4)       OTHERWISE MULTIPLY THEM TOGETHER.    11340000
         BXH   4,5,LJWS2           LOOP CLOSURE.                        11430000
LJWS3    LR    4,6                 MAKE FOUR AVAILABLE FOR IC.          11520000
         IC    4,MTYPE-M(1)        INSERT THE TYPE.                     11610000
         LH    2,MRANK-M(1)        GET THE RANK BACK.                   11700000
         SR    1,MR                MAKE THE BASE M-RELATIVE AGAIN.      11790000
         CR    3,6                 SEE IF THERE IS ONE COMPONENT.       11880000
         BCR   8,LKR               ALL IS WELL IF THERE IS.             11970000
         LR    6,7                 OTHERWISE MAKE R6 ZERO.              12060000
         BCR   2,LKR               SEE IF IT IS NOT EMPTY.              12150000
         C     4,OP4               CHARACTER TYPE STAYS AS IT IS,       12240000
         BCR   8,LKR                                                    12330000
         LA    4,2                 BUT NUMERIC EMPTIES ARE MADE INTEGER 12420000
         BCR   15,LKR              THEN EXIT.                           12510000
LJWS4    EQU   *                                                        12600000
LJWSEND  EQU   *                                                        12690000
         STC   8,TEMPRGT           SET TEMP INDICATOR.                  12780000
         STC   6,RHSCALAR          STORE SCALAR INDICATOR.              12870000
         STM   1,4,RHBASE          STORE ALL THAT STUFF.                12960000
*                                                                       13050000
*        NOW, DO ABOUT THE SAME FOR LH OPERAND.                         13140000
*                                                                       13230000
         L     1,4(9)              LOAD THE LEFT HAND BASE.             13320000
         BAL   LKR,LJWSET          SET UP LEFT SIDE.                    13410000
         STC   8,TEMPLFT           STORE TEMPORARY INDICATOR.           13500000
         STC   6,LHSCALAR          STORE SCALAR INDICATOR.              13590000
         STM   1,4,LHBASE          STORE THAT GOOD STUFF.               13680000
         BAL   LKR,PICKINDX                                             13770000
*                                                                       13860000
*        NOW, CALL ARTHTP.                                              13950000
*                                                                       14040000
         SR    0,0                 DON'T FORCE A TYPE.                  14130000
*                                                                       14220000
*        BLOWUP MAY RETURN HERE.                                        14310000
*                                                                       14400000
         ENTRY BLOWRTN                                                  14490000
BLOWRTN  LR    1,0                 FETCH THE RIGHT OR ONLY OPERATOR     14580000
         IC    1,OPERATOR+3                                             14670000
         L     2,LHTYPE            ,LEFT HAND TYPE.                     14760000
         L     3,RHTYPE            AND RIGHT HAND TYPE.                 14850000
         ICALL ARTHTP              AND CALL.                            14940000
         STM   1,5,TYPINFO         AND SAVE IT ALL.                     15030000
         L     2,OPERATOR                                               15120000
         C     2,=F'256'           DYADIC OR MATRIX                     15210000
         BNH   BCOT                DYADIC - DO SAME OLD DULL STUFF      15300000
         L     9,=A(MATRIX)        THE NEW EXCITING WORLD               15390000
         BALR  LKR,9               OFF TO THE MATRIX PRODUCT            15480000
         BC    15,LWCLEAN          CLEAN UP STACK                       15570000
BCOT     L     5,=A(INDICTR)       GET ENTRY IN OPERATOR INFO TABLE     15660000
         LA    5,1(2,5)                                                 15750000
         TM    0(5),INDEXED        TEST FOR INDEX ALLOWED.              15840000
         BO    NOXCHK              BRANCH IF SO.                        15930000
         L     1,OPINDEX                                                16020000
         LTR   1,1                 OTHERWISE,                           16110000
         BNZ   SYNTERR             SYNTAX ERROR IF INDEXED.             16200000
NOXCHK   TM    0(5),SCALAROP       SEE IF THIS IS A SCALAR OP.          16290000
         BNZ   SCOP                BRANCH IF SO.                        16380000
         L     9,OPRN              OTHERWISE,                           16470000
         BALR  LKR,9               CALL OPERATOR EXECUTION ROUTINE.     16560000
         BC    15,LWCLEAN          GO TO CLEANUP.                       16650000
*                                                                       16740000
*        NOW, CHECK FOR CONFORMABILITY, AND COMPUTE RESULT RANK.        16830000
SCOP     L     2,LHRANK                                                 16920000
         CLI   LHSCALAR,0          IS LEFT ARG ONE-COMPONENT --         17010000
         BE    SCOP1               NO.                                  17100000
         CLI   RHSCALAR,0          YES.  HOW ABOUT RIGHT ARG --         17190000
         BZ    USRHRANK            MULTICOMPONENT.  RESULT HAS RH RANK. 17280000
         C     2,RHRANK            BOTH ONE-COMPONENT.                  17370000
         BNL   USLHRANK            RESULT RANK IS HIGHER OF ARG RANKS.  17460000
         B     USRHRANK                                                 17550000
SCOP1    CLI   RHSCALAR,0          LEFT ARG MULTICOMPONENT.             17640000
         BNZ   USLHRANK            OK IF RIGHT ARG SCALAR               17730000
         C     2,RHRANK            OTHERWISE COMPARE RANKS              17820000
         BNE   RANKBAD             RANK ERROR IF UNEQUAL                17910000
         L     3,LHBASE            RANKS EQUAL, NOW COMPARE DIM         18000000
         L     4,RHBASE            SO CALCULATE BASE ADDRESSES.         18090000
         LA    3,MRHO(3)                                                18180000
         LA    4,MRHO(4)                                                18270000
         BCTR  2,0                                                      18360000
         EX    2,CMPLC             WHICH IS A CLC.                      18450000
         BNE   RANKEROR            BRANCH IF THEY'RE NOT EQUAL.         18540000
*                                                                       18630000
*        FALL THROUGH IF OK, SO USE RH RANK.                            18720000
*                                                                       18810000
USRHRANK L     5,RHBASE                                                 18900000
         L     4,RHRANK                                                 18990000
         L     3,RHXRHO                                                 19080000
         MVI   LTORRT,1                                                 19170000
         B     RESRANK                                                  19260000
USLHRANK L     5,LHBASE                                                 19350000
         L     4,LHRANK                                                 19440000
         L     3,LHXRHO                                                 19530000
         MVI   LTORRT,2                                                 19620000
*                                                                       19710000
*        NOW FIGURE OUT HOW MANY WORDS WE NEED FOR RESULT.              19800000
*                                                                       19890000
RESRANK  ST    3,RXRHO             STORE RESULT X/RHO.                  19980000
         ST    4,RRANK             AND THE RESULT RANK.                 20070000
         CLI   TYPINFO+15,2                                             20160000
         BL    BOOLOOR                                                  20250000
         BE    ADINF               INTEGER - 1 WORD PER ELEMENT.        20340000
FLOATOR  AR    3,3                 FLOAT, MULTIPLY BY 2.                20430000
         B     ADINF                                                    20520000
BOOLOOR  LA    3,31(3)                                                  20610000
         SRL   3,5                 DIVIDED BY 32.                       20700000
*                                                                       20790000
*        NOW, ADD IN NUMBER OF HEADER WORDS.                            20880000
*                                                                       20970000
ADINF    EQU   *                                                        21060000
         SLA   3,2                 MULTIPLY BY 4 TO GET BYTES.          21150000
         AR    3,4                 ADD RANK.                            21240000
         LA    1,MRHO-M(3)         ADD IN NUMBER OF HEAD WORDS.         21330000
*                                                                       21420000
*        NOW FIND SPACE FOR RESULT.                                     21510000
*        SEE IF WE CAN USE TEMPORARY STORAGE FIRST.                     21600000
*                                                                       21690000
         TM    TEMPRGT,1           TRY RUGHT.                           21780000
         BZ    TRYLEFT             BRANCH IF NOT TEMPORARY.             21870000
         L     3,RHBASE            GET THE BASE.                        21960000
         C     1,MCOUNT(3)                                              22050000
         BNE   TRYLEFT             BRANCH IF NOT.                       22140000
         L     2,RRANK             GET THE RANK.                        22230000
         CH    2,MRANK(3)                                               22320000
         BNE   TRYLEFT             SO BRANCH IF THEY'RE NOT.            22410000
         MVI   TEMPRGT,0           OTHERWISE, TURN OFF INDICATOR.       22500000
         B     GOTEMPR             WE'VE GOT IT.                        22590000
TRYLEFT  L     3,LHBASE            NOW TRY LEFT.                        22680000
         TM    TEMPLFT,1           SEE IF IT'S TEMP.                    22770000
         BZ    GETSP               BRANCH IF NOT.                       22860000
         C     1,MCOUNT(3)                                              22950000
         BNE   GETSP               BRANCH IF NOT.                       23040000
         L     2,RRANK             TEST RANKS.                          23130000
         CH    2,MRANK(3)                                               23220000
         BNE   GETSP               BRANCH IF NOT EQUAL.                 23310000
         MVI   TEMPLFT,0           OTHERWISE, CLEAR FLAG.               23400000
*                                                                       23490000
*        SET UP HEADER.                                                 23580000
*                                                                       23670000
GOTEMPR  L     9,SVI               PICK UP SVI AGAIN.                   23850000
         ST    9,MHEAD(3)          STORE REFLECTING POINTER.            23940000
         ST    3,M(9)                                                   24120000
         ST    3,RBASE             STORE RESULT POINTER.                24210000
         S     9,OP4                                                    24300000
         ST    9,SVI                                                    24390000
         LR    1,3                 MOVE RBASE TO R1.                    24480000
         B     HDSETUP             NOW, GO SET UP HEADER.               24570000
*                                                                       24660000
*        CALL GETSPACE, AND REFETCH OPERANDS.                           24750000
*                                                                       24840000
GETSP    LA    10,OPSPACE          ENTER COMMON GETSPACE ROUTINE.       24930000
         BAL   LKR,OPSCALL-OPSPACE(0,10)                                25020000
         ST    1,RBASE             STORE RESULT M-POINTER.              25110000
         SPACE                                                          25200000
*                                                                       25290000
*        NOW, SET UP HEADER.                                            25380000
*                                                                       25470000
         SPACE                                                          25560000
HDSETUP  L     2,RHBASE            FIND OUT WHO IS SUPPLYING RANK.      25650000
         TM    LTORRT,1                                                 25740000
         BNZ   *+8                 BRANCH IF NOT RIGHT.                 25830000
         L     2,LHBASE            OTHERWISE, USE LEFT                  25920000
         L     4,RRANK             PICK UP RESULT RANK.                 26010000
         ST    4,MTYPE(1)          STORED.                              26190000
         L     3,RSTYPE            PICK UP RESULT TYPE.                 26280000
         STC   3,MTYPE(1)          STORED.                              26370000
         LTR   4,4                 SEE IF RESULT IS SCALAR.             26460000
         BZ    XSETUP              BRANCH IF SO.                        26550000
         BCTR  4,0                 OTHERWISE, GET AN SS COUNT.          26640000
         LA    1,MRHO(1)           AND SOME ABSOLUTE POINTERS.          26730000
         LA    2,MRHO(2)           FOR RANK MOVE.                       26820000
         EX    4,MOVRANK           AND MOVE IN THE RANK.                26910000
         EJECT                                                          27000000
*                                                                       27090000
*        DYADIC SCALAR OP SET UP AND EXECUTE.                           27180000
*                                                                       27270000
*        FIRST, SEE IF RESULT IS EMPTY.                                 27360000
*        THEN, SET UP FETCH CALLS.                                      27450000
*                                                                       27540000
         SPACE                                                          27630000
XSETUP   L     8,RXRHO             LOOK AT NUMBER OF ELS IN RESULT.     27720000
         LTR   8,8                                                      27810000
         BC    8,LWCLEAN           BRANCH IF NONE.                      27900000
         MVI   FCHSCLR,0           TURN OFF EXTENSION INDICATOR.        27990000
         MVI   FCHSCLR,0           TURN OFF PRE-FETCH INDICATOR.        28080000
         L     1,LCTYPE            PICK UP LEFT CONVERSION CODE.        28170000
         C     1,OP1               SEE IF IT'S BOOLEAN TO BOOLEAN.      28260000
         BNE   NOLBOOLF            BRANCH IF NOT.                       28350000
         TM    RHSCALAR,1          OTHERWISE, SEE IF RIGHT IS SCALAR.   28440000
         BNZ   NOLBOOLF            BRANCH IF SO - 32 AT ONE TIME.       28530000
         C     1,RCTYPE            OTHERWISE, SEE IF RIGHT CC IS THE SA 28620000
         BE    NOLBOOLF            BRANCH  IF SO - 32 AT ONCE           28710000
         SR    1,1                 OTHERWISE, HAVE TO GO THROUGH FETCH. 28800000
NOLBOOLF SLA   1,4                 MAKE CCODE A QUADRUPLE WORD INDEX.   28890000
         LA    1,FCHTBL(1)         GET POINTER TO FETCH TABLE.          28980000
         LM    2,5,0(1)            AND PICK UP A SET OF FETCH OPERANDS. 29070000
         L     4,LHBASE            NOW, BUILD A FETCH ADDRESS.          29160000
         A     4,LHRANK            BASE + RANK                          29250000
         LA    4,MRHO-M(4)          + HEADER LENGTH.                    29340000
         TM    LHSCALAR,1          SEE IF LEFT CAN EXTEND.              29430000
         BZ    LSETUP              BRANCH IF NOT.                       29520000
         MVI   FCHSCLR,1           OTHERWISE, INDICATE PRE-FETCH.       29610000
         BALR  LKR,5               AND PRE-FETCH THE OPERAND.           29700000
         L     2,COMTYP            PICK UP THE COMPUTE TYPE.            29790000
         C     2,OP2               COMPARE WITH INTEGER TYPE.           29880000
         BH    LDXT                BRANCH IF FLOATING.                  29970000
         BE    LFXT                OR IF FIXED.                         30060000
         MVI   LHTYPE+3,1          BOOLEAN - SET LH TYPE ACCORDINGLY.   30150000
         SRA   0,31                AND EXTEND THE OPERAND TO A FULL WOR 30240000
LFXT     ST    0,XTNSHN            STORE THE EXTENDING OPERAND.         30330000
         LA    5,XTNFIX            REPLACE THE FETCH RTNE ADDRESS.      30420000
         B     LSETUP              SET UP IS COMPLETE.                  30510000
LDXT     C     2,OP4               SEE IF CTYPE IS PERCHANCE CHARACTER. 30600000
         BE    LFXT                BRANCH IF SO.                        30690000
         STM   0,1,XTNSHN          OTHERWISE, STORE FLOATING EXTENSION. 30780000
         LA    5,XTNFLT            AND REPLACE THE FETCH RTNE ADDRESS.  30870000
LSETUP   STM   2,5,LHFETCH         LEFT IS NOW SET UP.                  30960000
         SPACE                                                          31050000
         L     1,RCTYPE            NOW RIGHT, PICK UP FETCH CODE.       31140000
         C     1,OP1               SEE IF IT'S BOOLEAN.                 31230000
         BNE   NORBOOLF            BRANCH IF NOT.                       31320000
         TM    LHSCALAR,1          SEE IF LEFT EXTENDS.                 31410000
         BNZ   NORBOOLF            BRANCH IF SO - OI IN ONE BLOW.       31500000
         C     1,LCTYPE            SEE IF LEFT IS THE SAME.             31590000
         BE    NORBOOLF            BRANCH IF SO - 32 IN ONE BLOW.       31680000
         SR    1,1                 OTHERWISE, WE HAVE TO GO THROUGH FTC 31770000
NORBOOLF SLA   1,4                 FCODE BECOMES A QUADRUPLE WORD INDEX 31860000
         LA    1,FCHTBL(1)         GET POINTER INTO FETCH TABLE.        31950000
         LM    2,5,0(1)            PICK UP A SET OF FETCH OPERANDS.     32040000
         L     4,RHBASE            NOW BUILD DATA ADDRESS.              32130000
         A     4,RHRANK            BASE + RANK                          32220000
         LA    4,MRHO-M(4)         + HEADER LENGTH.                     32310000
         TM    FCHSCLR,1           SEE IF RIGHT WAS PRE-FETCHED.        32400000
         BNZ   RSETUP              BRANCH IF SO - CAN'T PREFETCH AGAIN. 32490000
         TM    RHSCALAR,1          OTHERWISE, SEE IF RIGHT CAN EXTEND.  32580000
         BZ    RSETUP              BRANCH IF NOT.                       32670000
         MVI   FCHSCLR,1           OTHERWISE, SET PRE-FETCH INDICATOR.  32760000
         BALR  LKR,5               AND PRE-FETCH.                       32850000
         L     2,COMTYP            NOW, LOOK AT CTYPE.                  32940000
         C     2,OP2               COMPARE TO INTEGER.                  33030000
         BH    RDXT                BRANCH IF FLOATING,                  33120000
         BE    RFXT                OR IF INTEGER.                       33210000
         MVI   RHTYPE+3,1          BOOLEAN - SET TYPE TO BOOL.          33300000
         SRA   0,31                AND EXTEND OPERAND TO WORD.          33390000
RFXT     ST    0,XTNSHN            STORE EXTENDING WORD.                33480000
         LA    5,XTNFIX            AND REPLACE FETCH RTNE ADDRESS.      33570000
         B     RSETUP              SET UP COMPLETE.                     33660000
RDXT     C     2,OP4               SEE IF CTYPE IS CHARACTER.           33750000
         BE    RFXT                BRANCH IF SO.                        33840000
         STM   0,1,XTNSHN          OTHERWISE, STORE FLOATING EXTENSION. 33930000
         LA    5,XTNFLT            AND REPLACE FETCH ROUTINE ADDRESS.   34020000
RSETUP   STM   2,5,RHFETCH         RIGHT IS NOW SETUP.                  34110000
         SPACE                                                          34200000
         L     2,COMTYP            PICK UP COMPUTE TYPE.                34290000
         C     2,OP3               SEE IF IT'S FLOATING.                34380000
         BNE   FIXFER              BRANCH IF NOT.                       34470000
         MVC   STOP(8),DSTL        MOVE IN STORE, LOAD INSTRUCTION.     34560000
         B     DSTORTN                                                  34650000
FIXFER   MVC   STOP(8),GSTL        FIXED STORE, LOAD OVER RIGHT FETCH.  34740000
DSTORTN  L     1,RSTYPE            NOW, PICK UP RESULT TYPE.            34830000
         OR    2,1                 SEE IF WE CAN DO 32 IN ONE BLOW.     34920000
         O     2,LHTYPE            CONSIDER OPERAND TYPES AS WELL.      35010000
         O     2,RHTYPE            CONSIDER OPERAND TYPES AS WELL.      35100000
         BCT   2,NOTBOOL           BRANCH IF NOT.                       35190000
         LA    8,31(8)             OTHERWISE, CHANGE ELEMENT COUNT -    35280000
         SRL   8,5                 INTO A WORD COUNT.                   35370000
         LA    1,2                 AND USE INTEGER STORE ROUTINE.       35460000
NOTBOOL  SLA   1,2                 MAKE RESULT TYPE A WORD INDEX.       35550000
         L     7,STRTBL(1)         PICK UP ROUTINE ADDRESS.             35640000
         L     6,RBASE             PICK UP RESULT M-POINTER.            35730000
         A     6,RRANK             ADD IN RESULT RANK.                  35820000
         LA    6,MRHO-M(6)         NOW POINTS TO WHERE RESULT GOES.     35910000
         LA    2,32                INITIALIZE BOOLEAN STORE.            36000000
         ST    2,STRSHIFT                                               36090000
         EJECT                                                          36180000
*                                                                       36270000
*        DYADIC EXECUTION LOOP.                                         36360000
*                                                                       36450000
         SPACE                                                          36540000
         L     9,OPRN              PICK EXECUTION ROUTINE ADDRESS.      36630000
         ON    XOF,=A(BLOWUP)                                           36720000
DOPLOOP  LM    2,5,RHFETCH         FETCH A RIGHT.                       36810000
         BALR  LKR,5               ENTER FETCH ROUTINE.                 36900000
         STM   2,5,RHFETCH         ALSO SAVE UPDATED FETCH OPERANDS.    36990000
         EX    0,STOP              STORE OVER LEFT FETCH.               37080000
         LM    2,5,LHFETCH         FETCH LEFT OPERAND.                  37170000
         BALR  LKR,5               GO GET IT.                           37260000
         STM   2,5,LHFETCH         SAVE UPDATED OPERANDS.               37350000
         LR    1,0                 MOVE LEFT TO R1.                     37440000
         EX    0,LOP               LOAD RIGHT AFTER FETCH.              37530000
         BALR  LKR,9               EXECUTE.                             37620000
         BCR   1,0                 NO OP INSERTED TO COMBAT IMPRECISE   37710000
*                                  INTERRUPTS ON THE MODEL 91           37800000
         BALR  LKR,7               STORE ROUTINE.                       37890000
         QUEND                                                          37980000
         B     DOPLOOP             IF STORE ROUTINE RETURNS, LOOP.      38070000
         SPACE 3                                                        38160000
         TITLE 'MONADIC EXECUTION CONTROL.'                             38250000
*                                                                       38340000
*        MONADIC EXECUTION CONTROL.                                     38430000
*                                                                       38520000
*        NOTE PROGRAM BASE REGISTER MANEUVER - NEEDED FOR               38610000
*              UNIFORM ADDRESSABILITY.                                  38700000
*                                                                       38790000
         SPACE                                                          38880000
DOMOP    PROLOG OPSECT,NDOPSECT    ENTRY.                               38970000
         ENTRY DOMOP                                                    39060000
         L     PR,=A(DODOP+6)      DOMOP MUST BE GE DODOP.              39150000
         USING DODOP+6,PR          THIS IS DEPENDENT ON PROLOG MACRO.   39240000
*                                  ***********************************  39330000
         SPACE                                                          39420000
         MVI   BLOWN,0             RESET BLOWUP INDICATOR.              39510000
         L     9,SVI               LOCATE STACKED EXPRESSION.           39600000
         AR    9,MR                USE AN ABSOLUTE POINTER.             39690000
         LM    15,1,4(9)           PICK UP MONADIC EXPRESSION.          39780000
         STM   15,0,OPERATOR       SAVE OPERATOR AND ITS INDEX          39870000
         LA    5,12                SET UP SVI INCREMENT.                39960000
         ST    5,INCR                                                   40050000
         BAL   LKR,LJWSET          SET UP THE GOOD STUFF.               40140000
         STC   8,TEMPRGT           STORE TEMPORARY INDICATOR.           40230000
         STC   6,RHSCALAR          STORE SCALAR INDICATOR.              40320000
         STM   1,4,RHBASE          STORE SOME MORE.                     40410000
         BAL   LKR,PICKINDX                                             40500000
         SPACE                                                          40590000
         SR    0,0                 DON'T FORCE A RESULT TYPE.           40680000
*                                                                       40770000
*        BLOWUP MAY RETURN HERE.                                        40860000
*                                                                       40950000
         ENTRY MBLOWRTN                                                 41040000
MBLOWRTN SR    2,2                 ZERO LHBASE AND TYPE.                41130000
         ST    2,LHTYPE                                                 41220000
         ST    2,LHBASE                                                 41310000
         LR    1,0                                                      41400000
         IC    1,OPERATOR+3        PICK UP THE OPERATOR                 41490000
         L     3,RHTYPE            AND RH TYPE.                         41580000
         CLI   OPERATOR+2,0        IS THIS REDUCE                       41670000
         BE    MC1                 NO                                   41760000
         LR    2,3                 YES SO REALLY DYADIC                 41850000
MC1      ICALL ARTHTP                                                   41940000
         STM   1,5,TYPINFO         SAVE THE RESULTS.                    42030000
         L     2,OPERATOR          PICK UP OPERATOR AGAIN.              42120000
         C     2,=F'256'                                                42210000
         BNH   MCOT                                                     42300000
         L     9,=A(REDUCE)        ISN'T THIS JUST GREAT                42390000
         BALR  LKR,9                                                    42480000
         BC    15,LWCLEAN                                               42570000
MCOT     L     5,=A(INDICTR)                                            42660000
         LA    5,0(2,5)                                                 42750000
         TM    0(5),INDEXED        SEE IF INDEX IS ALLOWED.             42840000
         BO    MNXCHK              BRANHC IF NOT.                       42930000
         L     1,OPINDEX           OTHERWISE, SEE IF THERE WAS ONE.     43020000
         LTR   1,1                                                      43110000
         BNZ   SYNTERR             SYNTAX ERROR IF SO.                  43200000
MNXCHK   TM    0(5),1              SEE IF IT'S A SCALAR OPERATOR.       43290000
         BNZ   MSCOP               BRANCH IF SCALAR.                    43380000
         L     9,OPRN              OTHERWISE, LINK TO NON-SCALAR ROUTIN 43470000
         BALR  LKR,9                                                    43560000
         BC    15,LWCLEAN          GO TO CLEANUP.                       43650000
         SPACE                                                          43740000
*                                                                       43830000
*        SET UP RESULT.                                                 43920000
*                                                                       44010000
         SPACE                                                          44100000
MSCOP    TM    0(5),X'80'          SEE IF AN INDEX IS ALLOWED.          44190000
         BO    MNOXCHK             BRANCH IF SO.                        44280000
         L     1,OPINDEX           OTHERWISE, CHECK FOR INDEX.          44370000
         LTR   1,1                 IT SHOULD BE ZERO.                   44460000
         BNZ   SYNTERR             SYNTAX ERROR IF NOT.                 44550000
MNOXCHK  L     2,RHRANK            PICK UP RESULT RANK.                 44640000
         ST    2,RRANK             SET RESULT RANK TO IT.               44730000
         L     3,RSTYPE            PICK UP TYPE.                        44820000
         L     1,RHXRHO            AND NO. OF ELEMENTS.                 44910000
         TM    TEMPRGT,1           SEE IF OPERAND IS TEMP.              45000000
         BZ    MGETSP              BRANCH IF NOT.                       45090000
         C     3,RHTYPE            COMPARE RESULT TO RH TYPE.           45180000
         BNE   MGETSP              BRANCH IF WE HAVE TO GET SPACE.      45270000
         L     9,SVI               OTHERWISE, PUT RESULT PTR ON STACK.  45360000
         L     1,RHBASE            ALSO ON TOP OF OPERAND.              45450000
         ST    9,MHEAD(1)          SET UP REFLECTING POINTERS.          45540000
         ST    1,M(9)              IN STACK AND M-ENTRY.                45630000
         S     9,OP4               MOVE DOWN STACK POINTER.             45720000
         ST    9,SVI               AND SAVE IT.                         45810000
         ST    1,RBASE                                                  45900000
         MVI   TEMPRGT,0                                                45990000
         B     MSETUP              NOW, REJOIN.                         46080000
         SPACE                                                          46170000
MGETSP   LA    10,OPSPACE          ENTER COMMON GETSPACE ROUTINE        46260000
         BALR  LKR,10                                                   46350000
         ST    1,RBASE             STORE RESULTING POINTER.             46440000
         L     3,RHRANK            SET UP HEADER.                       46530000
         ST    3,MTYPE(1)          STORE RANK,                          46710000
         L     4,RSTYPE                                                 46800000
         STC   4,MTYPE(1)          AND THE TYPE.                        46890000
         LTR   3,3                 SEE IF THERE'S ANY RANK VECTOR.      46980000
         BZ    MSETUP              BRANCH IF NOT.                       47070000
         L     2,RHBASE                                                 47160000
         LA    1,MRHO(1)           GET ABSOLUTE POINTERS.               47250000
         LA    2,MRHO(2)           FOR THE RANK MOVE.                   47340000
         BCTR  3,0                 GET SS COUNT FROM RANK.              47430000
         EX    3,MOVRANK           AND MOVE IN THE RANK VECTOR.         47520000
         EJECT                                                          47610000
*                                                                       47700000
*        MONADIC SCALAR SETUP AND EXECUTE.                              47790000
*                                                                       47880000
         SPACE                                                          47970000
MSETUP   L     8,RHXRHO            PICK UP NUMBER OF ELEMENTS.          48060000
         LTR   8,8                 SEE IF THERE ARE ANY.                48150000
         BC    8,LWCLEAN           BRANCH IF NONE.                      48240000
         MVI   FCHSCLR,0           TURN OFF EXTENSION FLAG.             48330000
         L     1,RCTYPE            PICK UP CONVERSION CODE.             48420000
         SLA   1,4                 CONVERT TO QUADRUPLE WORD INDEX.     48510000
         LA    1,FCHTBL(1)         GET POINTER INTO FETCH TABLE.        48600000
         LM    2,5,0(1)            PICK UP A SET OF OPERANDS.           48690000
         L     4,RHBASE            PICK UP OPERAND BASE.                48780000
         A     4,RHRANK            ADD RANK VECTOR LENGTH.              48870000
         LA    4,MRHO-M(4)         ADD HEAD LENGTH.                     48960000
         STM   2,5,RHFETCH         STORE OPERANDS.                      49050000
         L     1,RSTYPE            PICK UP RESULT TYPE.                 49140000
         L     2,COMTYP            SEE IF WE CAN DO 32 ELS AT A TIME.   49230000
         O     2,RHTYPE                                                 49320000
         OR    2,1                                                      49410000
         BCT   2,MNOBOOL           BRANCH IF NOT.                       49500000
         LA    8,31(8)             OTHERWISE, CHANGE ELCT TO WDCT.      49590000
         SRL   8,5                                                      49680000
         LA    1,2                 AND USE INTEGER STORE ROUTINE.       49770000
MNOBOOL  SLA   1,2                 CONVERT RESULT TYPE TO WORD INDEX.   49860000
         L     7,STRTBL(1)         AND PICK UP STORE ROUTINE ADDRESS.   49950000
         L     6,RBASE             PICK UP RESULT BASE.                 50040000
         A     6,RHRANK            ADD RANK.                            50130000
         LA    6,MRHO-M(6)         POINT AT FIRST RESULT ELEMENT.       50220000
         LA    2,32                INITIALIZE BOOLEAN STORE.            50310000
         ST    2,STRSHIFT                                               50400000
         SPACE 5                                                        50490000
*                                                                       50580000
*        MONADIC EXECUTION LOOP.                                        50670000
*                                                                       50760000
         SPACE                                                          50850000
         L     9,OPRN              PICK UP EXECUTION ROUTINE ADDRESS.   50940000
         ON    XOF,=A(BLOWUP)      SET FIXED OVERFLOW TRAP.             51030000
MOPLOOP  LM    2,5,RHFETCH         FETCH AN OPERAND.                    51120000
         BALR  LKR,5               THROUGH FETCH ROUTINE.               51210000
         STM   2,5,RHFETCH         STORE UPDATED FETCH OPERANDS.        51300000
         LR    2,0                 MOVE OPERAND TO RH REGISTER.         51390000
         LDR   2,0                                                      51480000
         BALR  LKR,9               EXECUTE OPERATOR.                    51570000
         BCR   1,0                 NO OP INSERTED TO COMBAT IMPRECISE   51660000
*                                  INTERRUPTS ON THE MODEL 91           51750000
         BALR  LKR,7               STORE.                               51840000
         QUEND                                                          51930000
         B     MOPLOOP             THAT'S ALL.                          52020000
         EJECT                                                          52110000
*                                                                       52200000
*        PICKINDX COMPUTES OPERATOR INDEX AND TESTS IF VALID INDEX      52290000
*****  THIS ROUTINE ASSUMES OPINDEX HAS BEEN SET *****                  52380000
*        CALLING SEQUENCE                                               52470000
*        L     10=A(PICKINDX)                                           52560000
*        BALR  LKR,10                                                   52650000
*        DATA RETURNED.                                                 52740000
*        'INDEX' CONTAINS                                               52830000
*          0-N      ORIGIN CORRECTED OPERATOR INDEX.                    52920000
*        INDBASE = 0 FOR ELIDED INDEX                                   53010000
*        INDBASE = 1 FOR INDEX (UPPER BYTE.)                            53100000
*                                                                       53190000
PICKINDX ST    LKR,REGSAV          SAVE LINK REGISTER                   53280000
         MVI   INDBASE,0           INITIALLY SET FOR ELIDED INDEX       53370000
         MVI   TEMPIND,0           SET INDEX TO TEMPORARY               53460000
         L     3,OPINDEX           GET THE OPERATOR INDEX               53550000
         LTR   3,3                 TEST FOR ELISION                     53640000
         BCR   8,LKR               RETURN IF INDEX ELIDED               53730000
         MVI   INDBASE,X'80'                                            53820000
         LH    2,MLSCT(3)          PICK UP COUNT OF LIST ELEMENTS       54000000
         BCT   2,RNGEROR           ERROR IF COUNT NE 1                  54090000
*        R2 IS ZERO IF THIS ROUTE IS TAKEN                              54180000
         L     4,MLSORG(3)         OTHERWISE, PICK UP FIRST LIST ELEM.  54270000
         LTR   4,4                 TEST IF TEMP OR POINTER              54360000
         BP    LISTTEMP            BRANCH IF TEMPORARY                  54450000
         BZ    RNGEROR             ERROR IF NULL                        54540000
         L     4,M(4)              INDIRECT -- GET M-ENTRY              54720000
         MVI   TEMPIND,1           MARK INDEX NOT TEMP                  54810000
LISTTEMP SR    3,3                                                      54900000
         IC    3,MTYPE(4)          GET TYPE                             54990000
         ST    3,INDTYPE           SAVE FOR FRACTIONAL FE\CH            55080000
         LH    1,MRANK(4)          AND RANK                             55170000
         CL    1,OP4               TEST IF SCALAR                       55260000
         BL    GETINDEX            BRANCH IF SCALAR                     55350000
         BNE   RANKBAD             MATRIX OR HIGHER = INDEX ERROR       55440000
         L     0,MRHO(4)           GET NO. OF ELEMENTS                  55530000
         BCT   0,RANKBAD           ERROR IF NOT ONE COMPONENT           55620000
GETINDEX LA    4,MRHO-M(4,1)       GET BASE OF DATA                     55710000
         ON    RNG,FLTINDX                                              55890000
         ICALL FETCHINT                                                 55980000
         S     0,IORIGIN           CORRECT FOR ORIGIN                   56070000
         ST    0,INDEX             INDEX IS RESULT                      56160000
GOTIND   ON    RNG                 DISABLE DOMAIN ERROR TRAP            56250000
         L     LKR,REGSAV          RESTORE RETURN REGISTER              56340000
         BR    LKR                 RETURN TO CALLER                     56430000
         SPACE 4                                                        56520000
FINDEX   EQU   INDRANK             MAKE IT EASY TO CHANGE               56610000
*              WE PROBABLY HAVE A FLOATING INDEX                        56700000
FLTINDX  CLI   INDTYPE+3,4         UNLESS THE DUMMY CODED               56790000
         BE    RANKBAD             A CHARACTER INDEX                    56880000
         AR    4,MR                                                     56970000
         MVC   DBLHOLD,0(4)        GOT IT                               57060000
         LA    3,8                 TO CONVERT ORIGIN TO FLOATING        57150000
*        SR    2,2                 SHOULD STILL BE ZERO                 57240000
         LA    4,IORIGIN-M         M-REL ADDRESS OF IORIGIN             57330000
FLT1     ICALL FETCH               CONVERT IT                           57420000
         LD    2,DBLHOLD           PICK UP INDEX                        57510000
         SDR   2,0                 SUBTRACT ORIGIN                      57600000
         STD   2,DBLHOLD           SAVE IT                              57690000
         MVC   FINDEX(8),DBLHOLD   STUFF IT                             57780000
         MVI   INDBASE,X'C0'       MARK INDEX FRACTIONSL                57870000
         B     GOTIND                                                   57960000
         TITLE 'SCALAR OP CONTROL FETCH AND STORE ROUTINES.'            58050000
*                                                                       58140000
*        SCALAR OP FETCH ROUTINES.                                      58230000
*                                                                       58320000
         SPACE                                                          58410000
*        FIXED - NO CONVERSION.                                         58500000
*        R2 - NOT USED.                                                 58590000
*        R3 - INCREMENT (0 IF OPERAND EXTENDING.).                      58680000
*        R4 - BASE.                                                     58770000
*                                                                       58860000
*        R0 - FETCHED OPERAND.                                          58950000
*                                                                       59040000
         SPACE                                                          59130000
FCHWORD  L     0,M(4)              PICK UP DATA.                        59220000
         AR    4,3                 ADD POINTER INCREMENT.               59310000
         BR    LKR                 AND RETURN.                          59400000
         SPACE                                                          59490000
*        FLOATING - NO CONVERSION.                                      59580000
*        R2 - DESTROYED.                                                59670000
*        R3,R4 - AS IN FIXED, ABOVE.                                    59760000
*                                                                       59850000
*        D0 - FETCHED OPERAND                                           59940000
*        R0,R1 - FETCHED OPERAND.                                       60030000
*                                                                       60120000
         SPACE                                                          60210000
FCHDBL   LA    2,M(4)              R2 DESTROYED.                        60300000
         LM    0,1,0(2)            PICK UP DOUBLE WORD.                 60390000
         STM   0,1,DTEMP           THROUGH TEMP STORAGE -               60480000
         LD    0,DTEMP             TO GET TO A DOUBLE REGISTER.         60570000
         AR    4,3                 ADD INCREMENT.                       60660000
         BR    LKR                 AND RETURN.                          60750000
         SPACE                                                          60840000
         SPACE                                                          60930000
*                                                                       61020000
*        CHARACTER FETCH.                                               61110000
*        REGISTERS AS IN FIXED.                                         61200000
*                                                                       61290000
         SPACE                                                          61380000
FCHCHAR  IC    0,M(4)              PICK UP CHARACTER.                   61470000
         SLL   0,24                LAND IT ON THE LEFT OF THE REGISTER. 61560000
         AR    4,3                 ADD INCREMENT.                       61650000
         BR    LKR                 AND RETURN.                          61740000
         SPACE                                                          61830000
*                                                                       61920000
*        CALL TO EXTERNAL FETCH ROUTINE.                                62010000
*                                                                       62100000
         SPACE                                                          62190000
EXFETCH  ST    LKR,SAVER           SAVE LINK OVER CALL.                 62280000
         ICALL FETCH               FETCH AN OPERAND.                    62370000
         L     LKR,SAVER           PICK UP LINK.                        62460000
         LA    2,1(2)              INCREMENT INDEX.                     62550000
         BR    LKR                 AND RETURN.                          62640000
         SPACE                                                          62730000
*                                                                       62820000
*        OPERAND EXTENSION FETCHES.                                     62910000
*                                                                       63000000
         SPACE                                                          63090000
XTNFIX   L     0,XTNSHN            FIXED - BOOLEAN, INTEGER , CHARACTER 63180000
         BR    LKR                                                      63270000
         SPACE                                                          63360000
XTNFLT   LD    0,XTNSHN            FLOATING.                            63450000
         BR    LKR                                                      63540000
         SPACE                                                          63630000
*                                                                       63720000
*        INTEGER TO BOOLEAN FETCH.                                      63810000
*                                                                       63900000
         SPACE                                                          63990000
FCHIBOOL L     0,M(4)              PICK UP INTEGER.                     64080000
         CL    0,OP1               SEE IF IT'S IN RANGE.                64170000
         BH    RNGEROR             QUIT IF NOT.                         64260000
         SLL   0,31                OTHERWISE, LEFT JUSTIFY IT.          64350000
         AR    4,3                 INCREMENT THE POINTER.               64440000
         BR    LKR                 AND RETURN.                          64530000
         SPACE                                                          64620000
*                                                                       64710000
*        INTEGER TO FLOATING FETCH.                                     64800000
*                                                                       64890000
         SPACE                                                          64980000
FCHIDBL  L     0,M(4)              PICK UP INTEGER.                     65070000
         AL    0,DUN231+4                                               65160000
         ST    0,DTEMP+4           INTO A WORK AREA.                    65250000
         LD    0,DTEMP             INTO A FLOATING REGISTER.            65340000
         LE    0,DUN231                                                 65430000
         SD    0,DUN231                                                 65520000
         STD   0,DTEMP             BACK TO GRS.                         65610000
         LM    0,1,DTEMP                                                65700000
         AR    4,3                 INCREMENT POINTER.                   65790000
         BR    LKR                 AND RETURN.                          65880000
         EJECT                                                          65970000
*                                                                       66060000
*              SINCE ARTHTP WILL ONLY ALLOW EQUAL AND NOTEQUAL TO       66150000
*        RETURN FOR EXECUTION, WE ASSUME THAT A FETCH OF A NUMERIC      66240000
*        QUANTITY FOR ONE OF THESE OPERATIONS IS REQUIRED.              66330000
*        SINCE CHARACTERS WILL BE LEFT JUSTIFIED WHEN FETCHED, AND      66420000
*        SINCE THE LAST 24 BITS OF A REGISTER WILL BE ZERO WHEN IT      66510000
*        CONTAINS A CHARACTER, WE LOAD FRACMASK (00FFFFFF) TO ENSURE    66600000
*        A NOT-EQUAL COMPARE.                                           66690000
*                                                                       66780000
         SPACE                                                          66870000
ILLCHAR  L     0,FRACMASK                                               66960000
         BR    LKR                                                      67050000
         EJECT                                                          67140000
*                                                                       67230000
*        STORE ROUTINES.                                                67320000
*                                                                       67410000
         SPACE                                                          67500000
*                                                                       67590000
*        BOOLEAN STORE ROUTINE.                                         67680000
*                                                                       67770000
         SPACE                                                          67860000
STRBOOL  ST    1,CURRES            STORE CURRENT RESULT.                67950000
         LM    0,2,GEARSHFT        GET SHIFT STATE.                     68040000
         SLDL  0,1                 CATENATE CURRENT RESULT.             68130000
         BCT   2,PUTBACK           DECREMENT SHIFT COUNT.               68220000
         ST    0,M(6)              STORE A WORD IF WE FALL THROUGH.     68310000
         LA    6,4(6)              INCREMENT RESULT POINTER.            68400000
         LA    2,32                RE-INITIALIZE SHIFT COUNT.           68490000
PUTBACK  STM   0,2,GEARSHFT        AND STORE SHIFT STATE.               68580000
         BCTR  8,LKR               BRANCH IF MORE TO BO.                68670000
         C     2,OP32              OTHERWISE, SEE IF WE JUST STORED.    68760000
         BE    NOSHFT              BRANCH IF SO.                        68850000
         SLL   0,0(2)              OTHERWISE, LEFT JUSTIFY.             68940000
         ST    0,M(6)              AND STORE.                           69030000
NOSHFT   B     LWCLEAN             ALL FINISHED.                        69120000
         SPACE                                                          69210000
*                                                                       69300000
*        INTEGER STORE.                                                 69390000
*                                                                       69480000
         SPACE                                                          69570000
STRFIX   ST    1,M(6)              STORE RESULT ELEMENT.                69660000
         LA    6,4(6)              BUMP RESULT POINTER.                 69750000
         BCTR  8,LKR               RETURN IF MORE TO GO.                69840000
         B     LWCLEAN             ALL FINISHED.                        69930000
         SPACE                                                          70020000
*                                                                       70110000
*        FLOATING STORE.                                                70200000
*                                                                       70290000
         SPACE                                                          70380000
STRFLT   STD   0,DTEMP             MOVE RESULT TO GRS.                  70470000
         LM    0,1,DTEMP                                                70560000
         LA    2,M(6)              GET ABSOLUTE RESULT POINTER.         70650000
         STM   0,1,0(2)            STORE RESULT ELEMENT.                70740000
         LA    6,8(6)              BUMP POINTER.                        70830000
         BCTR  8,LKR               BRANCH IF NOT FINISHED.              70920000
         B     LWCLEAN             OTHERWISE QUIT.                      71010000
         EJECT                                                          71100000
*                                                                       71190000
*        FETCH ROUTINE TABLE.                                           71280000
*                                                                       71370000
         SPACE                                                          71460000
*TYPE          INDEX,FETCHCODE,DATABASE,ROUTINE ADDR                    71550000
*        OR    UNUSED,INCR,DATABASE,ROUTINEADDR                         71640000
         SPACE                                                          71730000
         DC    0F'0'               WORD ALIGNMENT AREA.                 71820000
         ENTRY FCHTBL                                                   71910000
FCHTBL   EQU   *                                                        72000000
T0       FETCHES 0,1,0,EXFETCH                                          72090000
T1       FETCHES 0,4,0,FCHWORD                                          72180000
T2       FETCHES 0,4,0,FCHWORD                                          72270000
T3       FETCHES 0,8,0,FCHDBL                                           72360000
T4       FETCHES 0,1,0,FCHCHAR                                          72450000
T5       FETCHES 0,5,0,EXFETCH                                          72540000
T6       FETCHES 0,6,0,EXFETCH                                          72630000
T7       FETCHES 0,4,0,FCHIBOOL                                         72720000
T8       FETCHES 0,4,0,FCHIDBL                                          72810000
T9       FETCHES 0,9,0,EXFETCH                                          72900000
T10      FETCHES 0,10,0,EXFETCH                                         72990000
T11      FETCHES 0,11,0,EXFETCH                                         73080000
T12      FETCHES 0,12,0,EXFETCH                                         73170000
T13      FETCHES 0,0,0,ILLCHAR                                          73260000
         SPACE                                                          73350000
*                                                                       73440000
*        STORE ROUTINE TABLE.                                           73530000
*                                                                       73620000
         SPACE                                                          73710000
STRTBL   EQU   *-4                                                      73800000
         DC    A(STRBOOL)                                               73890000
         DC    A(STRFIX)                                                73980000
         DC    A(STRFLT)                                                74070000
         TITLE 'OPERATOR EXECUTION CLEANUP ROUTINE.'                    74160000
*                                                                       74250000
*        SCALAR OPERATION CLEANUP ROUTINE.                              74340000
*                                                                       74430000
*        SOME EXECUTION ROUTINES DIDDLE INCR.                           74520000
*        BE CAREFUL WHEN MODIFYING CLEANUP.                             74610000
*                                                                       74700000
LWCLEAN  BALR  PR,0                ESTABLISH THE BASE REGISTER.         74790000
CLEANUP  EQU   *                                                        74880000
         ENTRY CLEANUP                                                  74970000
         DROP  PR                                                       75060000
         USING CLEANUP,PR                                               75150000
         ON    XOF                 RESTORE ON CONDITION.                75240000
         L     9,SVI               GET SVI AGAIN.                       75330000
*                                                                       75420000
*        NOW, MARK GARBAGE.                                             75510000
*                                                                       75600000
GARBIT   TM    TEMPLFT,1           SEE IF LEFT TEMP.                    75690000
         BZ    GARBRT              BRANCH IF NOT.                       75780000
         L     3,LHBASE                                                 75870000
         LTR   3,3                 MAKE SURE WE HAD A LEFT.             75960000
         BZ    GARBRT              BRANCH IF NOT.                       76050000
         MKG   3                   OTHERWISE, MARK IT.                  76140000
GARBRT   TM    TEMPRGT,1           NOW TRY RIGHT.                       76230000
         BZ    SETSVI              BRANCH IF NOT TEMP.                  76320000
         L     3,RHBASE                                                 76410000
         LTR   3,3                 MAKE SURE RT IS STILL DEFINED        76500000
         BZ    SETSVI              MEANS OPERATOR IS USING RT           76590000
*                                  AS A RESULT                          76680000
         MKG   3                   OTHERWISE, MARK IT.                  76770000
SETSVI   L     7,M+4(9)            PICK UP RESULT M-POINTER.            76860000
         A     9,INCR              INCREMENT SVI.                       76950000
         ST    9,SVI               AND STORE IT.                        77040000
         L     1,M(9)              MARKING THE OPERATOR INDEX GARBAGE.  77130000
         ICALL MKGARB              NOTE THE ASSUMPTION ABOUT SVI.       77220000
         ST    7,M+4(9)            PUT RESULT ADDR AT PROPER PLACE IN S 77310000
         LA    9,4(9)              INCREMENT SVI.                       77400000
         LTR   7,7                 IF RESULT IS INDIRECT POINTER (TO    77490000
         BM    OPEND               SYMBOL TABLE), AVOID RELOCATION.     77580000
         LA    0,CONST             INSERT CLASS = TEMP IN STACKED       77670000
         STC   0,M(9)              M-POINTER.                           77760000
         ST    9,MHEAD(7)          AND STORE A REFLECTING POINTER.      77940000
OPEND    IRETURN                                                        78030000
         TITLE 'COMMON OP CONTROL SUBROUTINES.'                         78120000
*                                                                       78210000
*        CALCULATE X/RHO                                                78300000
*                                                                       78390000
*        ARGUMENTS..                                                    78480000
*        RANK  - R2                                                     78570000
*        BASE  - R3                                                     78660000
*        RESULT IN R1.                                                  78750000
*                                                                       78840000
*        REGISTERS 1 2 3 4 5 DESTROYED.                                 78930000
*                                                                       79020000
         SPACE                                                          79110000
CXRHO    EQU   *                                                        79200000
OPCXRHO  EQU   CXRHO               FOR EXTERNAL USERS.                  79290000
         ENTRY OPCXRHO                                                  79380000
         USING CXRHO,10                                                 79470000
         SPACE                                                          79560000
         LA    1,1                 INITIALIZE RESULT.                   79650000
         LTR   2,2                 SEE IF OPERAND IS SCALAR.            79740000
         BCR   8,LKR               QUIT EARLY IF SO                     79830000
         LA    5,4                 SET UP BXH CONSTANTS.                79920000
         LCR   4,5                 DECREMENT.                           80010000
         AR    3,MR                GET ABS POINTER TO OPERAND.          80100000
         L     1,MRHO-M-4(3,2)     PICK UP LAST RANK ELEMENT.           80190000
         BCT   5,CXBXH             SKIP FIRST MULTIPLY.                 80280000
         M     0,MRHO-M-4(3,2)     MULTIPLY BY NEXT RANK ELEMENT.       80370000
CXBXH    BXH   2,4,*-4             AND LOOP.                            80460000
         BR    LKR                                                      80550000
         EJECT                                                          80640000
*                                                                       80730000
*        OPERATOR COMMON GETSPACE.                                      80820000
*                                                                       80910000
*        CALLING                   R1 - NUMBER OF ELEMENTS (X/RHO).     81000000
*                                  R2 - RANK.                           81090000
*                                  R3 - TYPE.                           81180000
*                                                                       81270000
*        RETURN                    R1 - RESULT M-POINTER.               81360000
*                                  R2 - DESTROYED.                      81450000
*                                  R3 - DESTROYED.                      81540000
*                                                                       81630000
         SPACE                                                          81720000
*********************************************************************** 81810000
*                                                                       81900000
*        OP CONTROL MAKES ASSUMPTIONS                                   81990000
*        ABOUT THIS ROUTINE. CHECK BEFORE MODIFICATION.                 82080000
*                                                                       82170000
*********************************************************************** 82260000
         SPACE                                                          82350000
OPSPACE  EQU   *                                                        82440000
         ENTRY OPSPACE                                                  82530000
         ENTRY OPSCALL                                                  82620000
         USING OPSPACE,10                                               82710000
         CL    1,OVERSIZE          MAKE SURE REQUEST WITHIN             82800000
         BH    NOSPACE             FULLWORD CAPACITY                    82890000
         BCT   3,OPSF              BRANCH IF TYPE NOT BOOLEAN.          82980000
         A     1,OP31              OTHERWISE, CEIL OF                   83070000
         SRL   1,5                 N DIV 32 GIVES WORD COUNT.           83160000
         B     OPGET               GET THE SPACE.                       83250000
OPSF     BCT   3,OPSD              BRANCH IF NOT INTEGER                83340000
         B     OPGET               OTHERWISE, HAVE WORD COUNT.          83430000
OPSD     BCT   3,OPSC              BRANCH IF CHARACTER.                 83520000
         AR    1,1                 OTHERWISE, WE NEED N DOUBLEWORDS.    83610000
         B     OPGET                                                    83700000
OPSC     A     1,OP3               CHARACTER - CEIL OF                  83790000
         SRL   1,2                 N DIV 4 GIVES WORD COUNT.            83880000
OPGET    SLA   1,2                 X 4 GIVES BYTES.                     83970000
         LA    2,MRHO-M(2)         COMBINE RANK*4 AND OVERHEAD SPACE    84060000
         AR    1,2                 GUARANTEED NO OVERFLOW               84150000
OPSCALL  SR    2,2                                                      84240000
         ST    LKR,SAVER           SAVE LINK.                           84330000
         ICALL GETSPACE            GET THE SPACE.                       84420000
         L     LKR,SAVER           PICK UP LINK.                        84510000
         SPACE                                                          84600000
*                                                                       84690000
*        THE FOLLOWING RELOCATION IS REQUIRED IN CASE GARBAGE WAS COLLE 84780000
*        CTED.                                                          84870000
*                                                                       84960000
         SPACE                                                          85050000
         L     3,SVI               PICK UP STACK POINTER.               85140000
         A     3,INCR              LOOK AT RIGHT HAND OPERAND.          85230000
         L     2,M+4(3)            PICK UP RH OPERAND.                  85320000
         LTR   2,2                 SEE IF IT'S IN SYMBOL TABLE.         85410000
         BP    OPRDIR              BRANCH IF NOT.                       85500000
         L     2,M(2)              OTHERWISE, GO INDIRECT.              85590000
OPRDIR   N     2,FRACMASK          CLEAR HI-ORDER GARBAGE.              85680000
         ST    2,RHBASE            RIGHT IS RELOCATED.                  85770000
         CLI   LHTYPE+3,0          SEE IF THERE'S A LEFT OPERAND.       85860000
         BCR   8,LKR               BRANCH IF NOT.                       85950000
         S     3,=A(DYADLEN)       SUBTRACT LENGTH OF DYADIC EXP.       86040000
         L     2,M+8(3)            OTHERWISE, PICK UP LEFT OPERAND.     86130000
         LTR   2,2                 SEE IF IT'S IN ST.                   86220000
         BP    OPLDIR              BRANCH IF NOT.                       86310000
         L     2,M(2)              OTHERWISE, GO INDIRECT.              86400000
OPLDIR   N     2,FRACMASK          CLEAR HI-ORDER BYTE.                 86490000
         ST    2,LHBASE            LEFT RELOCATED.                      86580000
         BR    LKR                 RETURN.                              86670000
         SPACE                                                          86760000
NOSPACE  LA    1,EMFULL                                                 86850000
         ICALL ERROR               PR MAY HAVE BEEN CHANGED             86940000
DYADLEN  EQU   16                                                       87030000
         TITLE 'OUR ERROR ROUTINE.'                                     87120000
*                                                                       87210000
*        IF WE END UP HERE, THINGS ARE ROUGH.                           87300000
*                                                                       87390000
         DROP  10                                                       87480000
         USING DODOP+6,PR                                               87570000
EXERROR  EQU   *                                                        87660000
         LA    1,ESYSTEM           BOMB OUT ON SYSTEM ERROR.            87750000
         BC 15,ERRCALL             NO NEED TO DUPLICATE THE ICALL.      87840000
RANKEROR EQU   *                                                        87930000
         L     1,LHRANK            CHECK RANKS.                         88020000
         C     1,RHRANK                                                 88110000
         BNE   RANKBAD             IF NOT EQUAL, RANK ERROR.            88200000
         LA    1,ELENGTH           OTHERWISE, MUST BE LENGTH ERROR.     88290000
         BC 15,ERRCALL             NO NEED TO DUPLICATE THE ICALL.      88380000
RANKBAD  LA    1,ERANK                                                  88470000
         BC 15,ERRCALL             NO NEED TO DUPLICATE THE ICALL.      88560000
RNGEROR  EQU   *                                                        88650000
         LA    1,ERANGE            OUT OF RANGE.                        88740000
         BC 15,ERRCALL             NO NEED TO DUPLICATE THE ICALL.      88830000
*                                                                       88920000
*        SYNTAX ERROR - INDEXED SCALAR OPERATOR.                        89010000
*                                                                       89100000
SYNTERR  EQU   *                                                        89190000
         LA    1,ESYNTAX                                                89280000
         BC 15,ERRCALL             NO NEED TO DUPLICATE THE ICALL.      89370000
         SPACE                                                          89460000
*                                                                       89550000
*        VALUE ERROR - WE FOUND A ZERO M-POINTER.                       89640000
*                                                                       89730000
VALERR   LA    1,EVALUE                                                 89820000
ERRCALL  ICALL ERROR               COMMON ERROR ROUTINE CALL.           89910000
         TITLE 'CONSTANTS.'                                             90000000
*                                                                       90090000
*        CONSTANTS AND SYMBOLS.                                         90180000
*                                                                       90270000
SCALAROP EQU   1                                                        90360000
ODDOP    EQU   2                                                        90450000
INDEXED  EQU   X'80'                                                    90540000
BRANCH   EQU   1                                                        90630000
CMPLC    CLC   0(0,3),0(4)                                              90720000
         CNOP  0,4                                                      90810000
LJWSCONS DC    AL1(MLSTBIT)         THESE SIX CONSTANTS ARE LOADED WITH 90900000
         DC    XL3'000000'                                              90990000
OP1      DC    F'1'                                                     91080000
OVERSIZE EQU   *                                                        91170000
FRACMASK DC    XL4'00FFFFFF'       LOAD MULTIPLE INSTRUCTION, AND MUST  91260000
NEGFOUR  DC    XL4'FFFFFFFC'       NOT BE SEPARATED.                    91350000
         DC    F'1'                                                     91440000
         DC    F'0'                                                     91530000
OP2      DC    F'2'                                                     91620000
OP3      DC    F'3'                                                     91710000
OP4      DC    F'4'                                                     91800000
OP31     DC    F'31'                                                    91890000
OP32     DC    F'32'                                                    91980000
ALLONES  DC    X'FFFFFFFF'                                              92070000
CLASSC   DC    AL1(CONST,0,0,0)                                         92160000
FOUREASY DC    X'4E000000'                                              92250000
DZERO    DC    D'0'                                                     92340000
DUN231   DC    X'4E00000080000000'                                      92430000
MOVRANK  MVC   0(0,1),0(2)                                              92520000
GSTL     ST    0,DSAVE             STORE AND LOAD OVER LEFT FETCH.      92610000
         L     2,DSAVE             MUST FOLLOW GSTL ******************* 92700000
DSTL     STD   0,DSAVE             DOUBLE STORE AND LOAD OVER FETCH.    92790000
         LD    2,DSAVE             MUST FOLLOW DSTL ******************* 92880000
         LTORG                                                          92970000
         EXTRN FETCH                                                    93060000
         EXTRN GETSPACE                                                 93150000
         EXTRN ARTHTP                                                   93240000
         EXTRN FETCHINT                                                 93330000
         EXTRN ERROR                                                    93420000
         EXTRN BLOWUP                                                   93510000
         EXTRN EXDZ                                                     93600000
         EXTRN MKGARB                                                   93690000
         EXTRN INDICTR                                                  93780000
         END                                                            93870000
./  ADD    NAME=APLSOPEN
OPEN     TITLE 'A P L   D A S D   O P E N   R O U T I N E S   05/11/70' 00130000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00260000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00390000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00520000
OPLIB    CSECT                                                          00910000
         PRINT OFF                 COPY APLDEFN                         01040000
         COPY  APLDEFN                                                  01170000
         TITLE 'A P L   D A S D   O P E N   R O U T I N E S   05/11/70' 01300000
         PRINT ON                                                  C037 01430000
         EXTRN OUTWRTL                                             C037 01560000
         EXTRN AAPLSDCB                                                 01820000
         EXTRN ADIRTAB                                                  01950000
         EXTRN AMANHASH                                                 02080000
         EXTRN APLINIT                                                  02210000
         EXTRN ALIBPARS,ALIBPZ                                          02340000
         EXTRN AWSLEN                                                   02470000
         TITLE 'O P E N   A P L   L I B R A R Y   P A C K S   05/11/70' 03640000
*                                                                       03770000
*        OPLIB OPENS ALL LIBRARY EXTENTS, CALLING NOPEN FOR EACH.       03900000
*        THE EXTENTS ARE CHECKED TO MAKE SURE THEY ARE ALL OF THE SAME  04030000
*        DEVICE, AND THE PROGRAM IS CANCELLED IF THEY ARE NOT.          04160000
*        WHEN ALL LIBRARY EXTENTS ARE OPENED SUCESSFULLY, PRIMARY       04290000
*        AND SECONDARY DIRECTORY ADDRESSES ARE CALCULATED.              04420000
*        IF LIBRARY EXTENT ZERO IS NOT LARGE ENOUGH TO CONTAIN ALL      04550000
*        DIRECTORIES (UNLIKELY), WE CANCEL THE PROGRAM.                 04680000
*                                                                       04810000
OPLIB    CSECT                                                          04940000
         BALR  2,0                                                      05070000
         USING *,2                                                      05200000
         STM   0,15,SAVEALL                                             05330000
         DROP  2                                                        05460000
         BALR  12,0                                                     05590000
         USING *,12                                                     05720000
         LM    1,2,=A(ALIBPZ,ALIBPARS)                                  05980000
         L     1,0(1)                                                   06110000
         L     2,0(2)                                                   06240000
         STM   1,2,CDCBXLE+4       MOTHER COPY OF LIBPARS.              06370000
*        CFREDSK IS  MAX/FREEDSK      WHERE RHO FREEDSK IS PACKS,MANHAS 06630000
         LA    9,NOPEN                                                  06760000
         L     8,ADPAR                                                  06890000
         USING CDCPARS,8                                                07020000
LOL1     BALR  15,9                OPEN ONE FILE                        07150000
         MVC   CFREDSK,EXTLOW      FILE ZERO WILL HAVE THIS OVERWRITTEN 07280000
         L     2,ADPAR             INITIALIZE EXTENT COMPARE INNER LOOP 07410000
LOL4     CR    2,8                                                      07540000
         BE    LOL5                END OF EXTENT COMPARE                07670000
         CLC   PHYSAD,PHYSAD-CDCPARS(2)                                 07800000
         BNE   LOL6                DIFFERENT DEVICES                    07930000
LOL2     A     2,CDCBXLE                                                08060000
         B     LOL4                BACK TO TOP OF INNER LOOP            08190000
LOL6     CLC   TLENF,TLENF-CDCPARS(2)                                   08320000
         BE    LOL2                DEVICE TYPES IDENTICAL               08450000
         LA    1,DTM               LIBRARY DEVICE TYPES DIFFER          08580000
         MVC   BUF1(44),DSLAB      STANDARD LOCATION TO PRINT FROM      08710000
         MVI   BUF1+44,X'FF'       END OF STATEMENT CODE FOR OUTWRTL    08840000
         ICALL OUTWRTL                                                  08970000
         DC    AL4(BUF1)                                                09100000
         MVC   BUF1(44),DSLAB-CDCPARS(2)                                09230000
         ICALL OUTWRTL                                                  09360000
         DC    AL4(BUF1)                                                09490000
LOGEOJ2  ST    1,LOGEOJ3                                                09620000
         CNOP  2,4                 FORCE ALIGNMENT OF TEXT ADDRESS      09750000
         ICALL OUTWRTL                                                  09880000
LOGEOJ3  DC    AL4(*-*)                                                 10010000
         ABEND 1410                                                 K12 10530000
EXTOMIN  LA    1,ETM               LIB 0 TOO SMALL FOR DIRECTORIES      10790000
         B     LOGEOJ2                                                  10920000
*                                                                       11050000
*        END OF INNER LOOP                                              11180000
*                                                                       11310000
LOL5     LM    0,1,CDCBXLE                                              11440000
         BXLE  8,0,LOL1            OPEN NEXT FILE                       11570000
*                                                                       11700000
*        CALCULATE PRIMARY AND SECONDARY DIRECTORY ADDRESSES.           11830000
*        R7 IS DIRTAB ADDRESS.  ASSUME DIRTAB  DS  (2*MANHASH+1)F       11960000
*        R15 IS RETURN                                                  12090000
*                                                                       12220000
         USING CDCPARS,8                                                12350000
         L     7,=A(ADIRTAB)       INDIRECT ADDRESS TO FIND DIRTAB.     13000000
         L     7,0(7)                                                   13130000
         S     7,=F'4'                                                  13260000
         L     1,=A(AMANHASH)      AND MANHASH.                         13390000
         L     1,0(1)                                                   13520000
         L     1,0(1)              COMPUTE 1+2*MANHASH                  13650000
         LA    0,1(1,1)            1 EXTRA FOR CFREDSK                  13780000
         L     8,ADPAR             FILE ZERO CONTAINS DIRECTORIES       13910000
         L     1,EXTLOW                                                 14040000
         MVI   ADSW,0              START WITH PRIMARY DIRECTORY         14170000
         B     ALTCZ               FIRST DIRECTORY IS AT EXTLOW         14300000
*                                                                       14430000
MLOOP    AH    1,TPERWS                                            5989 14560000
         BAL   15,ALTCP            PROPAGATE CARRY FROM HEAD TO CYL     14690000
         XI    ADSW,1              FLIP PRIM VS ALT STATE               14820000
         BZ    ALTCZ               PRIMARY DIRECTORY                    14950000
         EX    1,ALTC3             CHECK FOR PRIM & ALT HEADS =         15080000
         BNE   ALTCZ                                                    15210000
         LA    1,1(1)              WASTE ONE TRACK                      15340000
         BAL   15,ALTCP            PROPAGATE CARRY                      15470000
ALTCZ    CL    1,EXTUP                                                  15600000
         BNL   EXTOMIN             EXTENT CAN'T HOLD DIRS AND ALTS      15730000
         ST    1,4(7)              R7 = DIRTAB ADDR, -4                 15860000
         LA    7,4(7)              ADVANCE                              15990000
         BCT   0,MLOOP                                                  16120000
         ST    1,CFREDSK                                                16250000
         LM    0,15,SAVEALL                                             16380000
         BR    15                                                       16510000
ALTCP    EX    1,ALTC1             PROPAGATE CARRY IN CCHH REPRESENTATN 16640000
         BCR   2,15                SAME CYLINDER                        16770000
         A     1,CCADJ             2*16 - HEADS PER CYL                 16900000
         B     ALTCP                                                    17030000
*                                                                       17160000
ALTC1    CLI   HMAX+1,0                                                 17290000
ALTC3    CLI   3(7),0              PRIMARY HEAD                         17420000
*                                                                       17550000
*        OPLIB ERROR MESSAGES                                           17680000
*                                                                       17810000
ETM      DC    C'LIBRARY EXTENT 0 TOO SMALL FOR DIRECTORIES',X'FF'      17940000
DTM      DC    C'LIBRARY DEVICE TYPES DIFFER',X'FF'                     18070000
*                                                                       18200000
SAVEALL  DS    16F                 OPLIB REGISTER SAVE AREA             18330000
ADSW     DS    X                                                        18460000
         TITLE 'A P L   D I R E C T - A C C E S S   O P E N   05/11/70' 18590000
*                                                                       18720000
*        NOPEN OPENS ONE DASD EXTENT, FILLING IN THE FIELDS IN CDCPARS  18850000
*        FOR THAT EXTENT.  ON ENTRY, CDCPARS CONTAINS LOGAD AND DSLAB.  18980000
*        ON EXIT, ALL FIELDS ARE VALID.                                 19110000
*                                                                       19240000
*        R0-R6 ARE USED                                                 19370000
*        R8 IS BASE REGISTER FOR CDCPARS                                19500000
*        R9 = A(NOPEN)                                                  19630000
*        R15 IS RETURN                                                  19760000
*                                                                       19890000
         ENTRY NOPEN                                                    20020000
         USING NOPEN,9             SET BY CALLER                        20150000
         USING CDCPARS,8     REFERS TO SWAPPARS, OR LIBNPARS            20280000
NOPEN    ST    15,SAVA             SAVE RETURN ADDRESS                  39390000
         L     1,=A(AWSLEN)        ENTRY IN SUPINI OR APLUMAIN.         39520000
         L     1,0(1)              DOUBLE INDIRECT ADDRESSING.          39650000
         L     1,0(1)              VALUE OF WORKSPACE LENGTH.           39780000
         ST    1,WLEN                                                   39910000
         L     4,=A(AAPLSDCB)      ENTRY IN SUPINI AND APLUMAIN.        40040000
         L     4,0(4)              INDIRECT ADDRESSING.                 40170000
         LH    1,LOGAD       NUMBER I (CORRESP. TO ITH DCB IN DPARS)    40300000
         LTR   1,1           TEST LOGAD. CODE OF 0 NOT ALLOWED.         40430000
         BM    ERROR1                                                   40560000
         MH    1,=H'72'            MULTIPLY BY LENGTH OF DCB            40690000
         AR    4,1                 ADDBASE OF DCB TABLE TO INDEX        40820000
         USING IHADCB,4                                                 40950000
         MVC   DDNAME(8),DCBDDNAM        TEMPORARY DDNAME AREA          41080000
         OPEN  ((4),(OUTPUT))      OPEN DCB FOR INPUT AND OUTPUT        41210000
         TM    DCBOFLGS,X'10'      IS OPEN SUCCESSFUL                   41340000
         BZ        ERROR2                                           K12 41470000
         L     5,DCBIFLGS          GR5=FLAGS,A(DATA EXTENT BLOCK)       41600000
         LA    5,0(5)                                                   41730000
* DCBIFLGS OVERLAYS DCBDDNAM+4 DURING OPEN                              41860000
* GR5=A(DEB)                                                            41990000
         CLI   DEBNMEXT(5),1  TEST FOR SINGLE EXTENT DATASET       8021 42120000
         BNE   ERROR3         GIVE ABEND                           8021 42250000
         MVC   EXTLOW(8),DEBSTRCC(5) MOVE LOWER AND UPPER EXTENTS OF   X42380000
                                   FIRST EXTENT                         42510000
         DEVTYPE  DDNAME,TRCYLBYT,DEVTAB                                42640000
         L     1,ASWAPARS         ADDRESS OF A(SWAPPAR) IN SUPINI  3043 42770000
         CL    8,0(1)             SWAP BEING OPENED?               3043 42900000
         BNE   LIBOPEN                  NO                         3043 43030000
         CLI   EXTLOW+3,X'00'     START ON CYL BOUNDARY?           3043 43680000
         BNE   ERROR4                   NO                         3043 43810000
         LH    1,TRCYLBYT+10            TRKS PER CYL               3043 43940000
         BCTR  1,0                      MINUS ONE                  3043 44070000
         CH    1,EXTUP+2          END ON CYL BOUNDARY?             3043 44200000
         BNE   ERROR4                   NO                         3043 44330000
LIBOPEN  EQU   *                                                   3043 44460000
         MVC   TLENF+2(2),TRCYLBYT+6 TLENF GETS MAX BYTES/RECORD   DASD 44590000
         NC    TLENF(4),=X'0000FFF8' ROUND DOWN TO DOUBLE WORD.         44720000
         TM    TRCYLBYT,DCDEV     CAN THIS DEVICE SUPPORT DATACHAIN5989 44850000
         BO    HASDC              YES IT CAN                       5989 44980000
         OI    CDCFLAGS,CDCNDC    SET NO-DATA-CHAIN FLAG           5989 45110000
HASDC    EQU   *                                                   5989 45240000
         MVC   HMIN(2),=H'0'       ZERO HMIN.                           45370000
         TM    TRCYLBYT+1,RPSDEV   CAN THIS DEVICE REALLY USE RPS  DASD 45500000
         BNZ   HASRPS              YES                             DASD 45630000
         NI    CDCFLAGS,X'FF'-RPS  IF RPS WAS SELECTED, CANCEL IT  DASD 45760000
HASRPS   EQU   *                                                   DASD 45890000
         TM    DEBOFLGS(5),X'04'  TEST FOR SPLIT CYLINDER.              46020000
         BZ    NOTSPLIT                BRANCH ON NOT SPLIT              46150000
         MVC   HMIN(2),EXTLOW+2        SET HMIN = HH OF LOWER EXTENT    46280000
         LA    0,1                                                      46410000
         AH    0,EXTUP+2               COMPUTE HMIN=HH OF UPPR EXT+1    46540000
         STH   0,HMAX                                                   46670000
         B     AFHMAX                                                   46800000
NOTSPLIT MVC   HMAX(2),TRCYLBYT+10 HMAX CONTAINS NUMBER OF TRACSK/CYL.  46930000
AFHMAX   L     0,=A(X'10000')                                           47060000
         AH    0,HMIN                                                   47190000
         SH    0,HMAX                                                   47320000
         ST    0,CCADJ             (2*16)+HMIN-HMAX                     47450000
         SR    0,0                 GR0=0 FOR DIVIDE                     47580000
         L     1,WLEN              COMPUTE TRACKS PER WORKSPACE.        47710000
         A     1,TLENF             ROUND QUOTIENT UP                    47840000
         BCTR  1,0                                                      47970000
         D     0,TLENF                                                  48100000
         STH   1,TPERWS            IS CEIL WSLENGTH DIV TRMAX      5989 48230000
         L     3,32(5)             UCB ADDRESS.                         48360000
         LH    3,4(3)              UNIT ADDRESS.                        48490000
         STH   3,PHYSAD            DEVICE ADDRESS.                      48620000
         LR    1,5                 DEB ADDRESS.                         48750000
         LR    0,4                 DCB ADDRESS.                         48880000
         SVCC  INIT                SET FILE MASK TO ZERO.               49010000
         L     15,SAVA             RESTORE RETURN ADDRESS               49140000
         BR    15                                                       49270000
         SPACE 3                                                    K12 49400000
ERROR1   ABEND 1420,DUMP      INVALID DCB NUMBER                   C055 49530000
ERROR2   ABEND 1430,DUMP           OPEN NOT SUCCESSFUL             C055 49660000
ERROR3   ABEND 1440,DUMP           NOT A SINGLE EXTENT DATA SET    C055 49790000
ERROR4   ABEND 1450                     SWAP NOT ON CYL BOUNDARY   3043 49920000
         EXTRN ASWAPPAR                                            3043 50050000
ASWAPARS DC    A(ASWAPPAR)                                         3043 50180000
SAVA     DS    1F                  RETURN ADDRESS                       50310000
WLEN     DS    F                                                        50440000
DDNAME   DS    8C                                                       50570000
TRCYLBYT DS    5F                                                       50700000
CDCBXLE  DC    A(CDCL,0,0)         CDCL,LIBPZ,LIBPARS              C037 50830000
ADPAR    EQU   CDCBXLE+8                                           C037 50960000
BUF1     DS    44C'*',X'FF'        MESSAGE BUFFER FOR OPLIB             51090000
DEBOFLGS EQU   8                       FLAG BYTE OF DEB                 51220000
DEBNMEXT EQU   16                                                       51350000
DEBSTRCC EQU   38                                                       51480000
         TITLE 'A P L   D I S K   F O R M A T   R O U T I N E 05/11/70' 51740000
*                                                                       51870000
*              FORMATS A DASD DEVICE ACCORDING TO                  DASD 52000000
*        PARAMETRIC CONTROL BLOCK.                                 DASD 52130000
*        ON ENTRY, R1  = ADDRESS OF CONTROL INFORMATION                 52260000
*                        (SEE DKFMPAR DSECT FOR LAYOUT)                 52390000
*                  R15 = RETURN ADDRESS                                 52520000
*        REGISTERS R0 - R9 USED                                         52650000
*        REGISTERS R10 - R14 UNTOUCHED                                  52780000
         ENTRY DISKFMT                                                  52910000
DISKFMT  BALR  9,0                 ESTABLISH ADDRESSABILITY             53040000
         USING *,9                                                      53170000
         ST    15,SAV15           SAVE RETURN REG TO SUPINI             53300000
         LR    8,1                                                      53430000
         USING DKFMPAR,8                                                53560000
         L     7,CDCBASE                                                53690000
         USING CDCPARS,7                                                53820000
         XC    WSCT(4),WSCT                                             53950000
         MVC   PERD(4),PERDAD      BASE OF TABLE FOR CCHH OF       DASD 54080000
*                                  SWAP AREA TRACKS                     54210000
         L     4,=A(IOB)                                                55510000
         USING IOBECB,4           ESTABLISH ADDRES. FOR IOBECB DSECT    55640000
         LH    1,LOGAD                                                  55770000
         MH    1,=H'72'                                                 55900000
         L     2,=A(AAPLSDCB)      INDIRECT ADDRESS.                    56030000
         A     1,0(2)                                                   56160000
         ST    1,IOBDCB                                                 56290000
         MVI   CMRPS,NOP           RESET TO A NO OP COMMAND        DASD 56420000
         TM    CDCFLAGS,RPS        SHOULD RPS BE USED              DASD 56550000
         BZ    NORPS               NO                              DASD 56680000
         MVI   CMRPS,SETSECTR      MOVE IN SET SECTOR COMMAND      DASD 56810000
NORPS    EQU   *                                                   DASD 56940000
         MVC   CHREA+2(4),EXTLOW   CCHHR OF FIRST TRACK                 57070000
         LH    0,HMAX                                                   57200000
         SH    0,HMIN                                                   57330000
         ST    0,TPERCY                                                 57460000
         MVI   NEWWS,0             WE ARE STARTING A NEW WS             57590000
         L     1,TLENF             MOVE IN TRACK LENGTH AS COUNT        57720000
         STH   1,CKD+6             FOR WRITE COUNT, KEY, DATA           57850000
*                                                                       57980000
*              BUILD COMMAND CHAIN FOR CYLINDER.                        58110000
BCC0     L     5,TPERCY                                                 58240000
         CLI   BADTRKS,0           IF BAD TRACKS IN PREVIOUS CYLINDER   58370000
         BE    MCTP1               ARE ENCOMPASSED BY CURRENT WS,       58500000
BCC1     MVI   BADTRKS,0           CLEAR BAD TRACKS INDICATOR           58630000
         LH    6,TPERWS            AND START NEW WS AT HEAD 0      5989 58760000
         MVC   WSCYL(4),CHREA+2                                         58890000
MCTP1    TS    NEWWS               IF THIS TRACK STARTS A NEW WORKSPACE 59020000
         BZ    BCC1                SET UP WORKSPACE COUNT, FLAGS ETC    59150000
         MVC   CKD(4),CHREA+2      SET COUNT AREA TO CCHH               59280000
*              EXECUTE COMMAND CHAIN.                                   61100000
*              FOR SWAP AREA, SIMPLY BYPASS BAD TRACKS.                 61230000
*              FOR NON-SWAP AREA, FORMAT ALTERNATE TRACK.               61360000
         LA    10,CMCHN           MOVE ADDR. OF CHN PGM INTO IOB        61490000
         ST    10,IOBSIOCC                                              61620000
         MVC   IOBSKPT+2(4),CHREA+2 MOVE CCHH INTO IOB FOR STAND   DASD 61750000
*                                           ALONE SEEK                  61880000
         MVI   EVNTCB,X'00'  RESET ECB TO 0.                            62010000
         EXCP  IOB                EXECUTE CHN PGM                       62140000
         WAIT  ECB=EVNTCB         WAIT FOR COMPLETION OF CHN PGM        62270000
         CLI   EVNTCB,X'7F'  DID CHAN PROGM END NORMALLY  ?             62400000
         BE    MCTP               IF YES, BRANCH.                       62530000
         L     2,IOBFLAG3                                               62660000
         S     2,=A(CMSCH+8-CMCHN) LOCATE THE SCHIDE                    62790000
         MVC   SENSE(2),IOBSENS0       MOVE IOB SENSE INFO              62920000
         UNPK  UCMSGU(5),PHYSAD(3)     CHAN AND UNIT NUMBER             63310000
         TR    UCMSGU(4),XTR                                            63440000
         MVI   UCMSGU+4,C','                                            63570000
         UNPK  UCMSGS(9),SENSE(5)      SENSE DATA                       63700000
         TR    UCMSGS(8),XTR                                            63830000
         MVI   UCMSGS+8,C','                                            63960000
         UNPK  UCMSGC(5),CHREA+2(3) CONVERT CYL ADDRESS            DASD 64090000
         UNPK  UCMSGC+4(3),CHREA+5(2) AND HEAD ADDRESS             DASD 64220000
         TR    UCMSGC(6),XTR                                       DASD 64350000
         MVI   UCMSGC+6,X'FF'      MARK THE END OF THE MESSAGE     DASD 64480000
         ICALL OUTWRTL             OUTPUT SENSE MESSAGE TO OPERATOR     64610000
         DC    AL4(UCMSG)                                               64740000
         OI    BADTRKS,1           MARK THE WORKSPACE UNUSABLE          64870000
*                                                                       65000000
*        MOVE CCHH'S TO PERDISK (IF SWAP AREA)                     DASD 65130000
MCTP     BCT   6,MCTP4                                                  65260000
         CLI   ISSWAP,0            NO WSS PER SE IF NOT SWAP AREA.      65390000
         BE    MCTP4                                                    65520000
         MVI   NEWWS,0             STARTING NEW WORKSPACE               65650000
         CLI   BADTRKS,0           ALL TRACKS IN WORKSPACE CHECKED.     65780000
         BNE   MCTP4               SOME BAD TRACKS.  BYPASS THIS WS.    65910000
         L     1,PERD                                                   66040000
         USING PERDISK,1                                                66170000
         MVC   PDDA,WSCYL          MOVE STARTING CCHH INTO PERDISK DASD 66300000
         MVC   PDXTENT(1),EXTENT+1 MOVE EXTENT INDEX TO PERDISK         66430000
         DROP  1                                                        66560000
         A     1,PERDINC           STEP TO NEXT PERDISK ENTRY           66690000
         ST    1,PERD                                                   66820000
         L     1,WSCT              BUMP COUNT OF WORKSPACES IN SWAP     66950000
         LA    1,1(1)              AREA                                 67080000
         ST    1,WSCT                                                   67210000
         L     15,SAV15            RESTORE REG 15                       67340000
         C     1,WSS               DO WE HAVE ENOUGH FORMATTED --       67470000
         BCR   8,15                YES.  RETURN.                        67600000
*        INCREMENT TO NEXT TRACK                                        67730000
MCTP4    CLC   CHREA+2(4),EXTUP    WAS THAT THE LAST TRACK              67860000
         BNL   MCTP7               YES, QUIT                            67990000
         LH    1,CHREA+4           INCREMENT HEAD                       68120000
         LA    1,1(1)                                                   68250000
         STH   1,CHREA+4                                                68380000
         BCT   5,MCTP1             CONTINUE UNTIL ALL TRACKS IN CYL     68510000
*                                  HAVE BEEN LOOKED AT                  68640000
         LH    1,CHREA+2           WHEN DONE, ADVANCE CYLINDER NO.      68770000
         LA    1,1(1)                                                   68900000
         STH   1,CHREA+2                                                69030000
         MVC   CHREA+4(2),HMIN     RESET HEAD NUMBER                    69160000
         B     BCC0                START A NEW CYLINDER                 69290000
*        UPPER EXTENT  (CCHH) HAS BEEN REACHED                          69420000
MCTP7    L     15,SAV15            RESTORE REGISTER 15                  69550000
         CLI   ISSWAP,0                                                 69680000
         BCR   8,15 BZR            RETURN IF EXTENT NOT SWAP            69810000
         ICALL OUTWRTL             SEND ERROR MESSAGE TO OPERATOR       70980000
         DC    AL4(NSAMG)          'INSUFFICIENT SWAP AREA'             71110000
         ABEND 1400           INSUFFICIENT SWAP AREA                K12 71630000
*                                                                       71890000
*        DISKFMT ERROR MESSAGES                                         72020000
*                                                                       72150000
UCMSG    DC    C'OCUU='            UNIT CHECK ERROR MESSAGE             72280000
UCMSGU   DC    C'3XXX,SENSE='                                      C037 72410000
UCMSGS   DC    C'XXXXXXXX,CCH='                                    DASD 72540000
UCMSGC   DC    C'XXXXXX '                                          DASD 72670000
NSAMG    DC    C'INSUFFICIENT SWAP AREA',X'FF'                          72800000
*                                                                       72930000
*        DISKFMT DASD CHANNEL PROGRAMS                                  73060000
*                                                                       73190000
         DC    0F'0'                                                    74100000
IOB      DC    X'42000000'                                              74230000
         DC    X'00'                                                    74360000
         DC    AL3(ECB)                                                 74490000
         DC    2F'0'                                                    74620000
         DC    X'00'                                                    74750000
         DC    AL3(0)                                                   74880000
         DC    A(0)                                                     75010000
         DC    4F'0'                                                    75140000
ECB      DC    F'0'                                                     75270000
*                                                                       75530000
CMCHN    CCW   SEEK,CHREA,CC,6                                          75660000
CMRPS    CCW   SETSECTR,SECTOR,CC,1 WILL BE A NO-OP IF RPS NOT USEDDASD 75920000
CMSCH    CCW   SCHIDE,CHREA+2,CC,5                                      76180000
         CCW   TIC,*-8,0,0                                              76310000
CMWCKD   CCW   X'1D',CKD,X'20',8   WRITE CKD                            76440000
*                                                                       76570000
SETSECTR EQU   X'23'               SET SECTOR COMMAND FOR RPS      DASD 76700000
NOP      EQU   3                   NO OP COMMAND                   DASD 76830000
DCDEV    EQU   X'10'          DC DEVICE (OS DEVTYP)                5989 76960000
RPSDEV   EQU   X'10'               RPS DEVICE FROM OS OPTION BYTE  DASD 77090000
TIC      EQU   X'08'                                                    77220000
SEEK     EQU   X'07'                                                    77350000
SCHIDE   EQU   X'31'                                                    77480000
CC       EQU   X'40'                                                    77610000
*                                                                       77740000
CHREA    DC    D'0'                SK/SCH ADDR, BAD TRACK FLAG          77870000
BADTRKS  DC    X'0'                                                     78000000
SECTOR   DC    X'0'                SECTOR ZERO FOR FULL TRACK RECS DASD 78130000
EXTENT   DC    H'0'                SWAP EXTENT INDEX                    78260000
CKD      DC    Y(0,0,256,*-*)                                           78390000
SENSE    DS    6X                                                       78520000
SAV15    DS    F                   R15 SAVE AREA                        78650000
NEWWS    DS    X                                                        78780000
WSCYL    DS    F                   CCHH OF FIRST TRACK, THIS WORKSPACE  78910000
WSCT     DS    F                   WSS FORMATTED IN SWAP AREA SO FAR    79040000
PERD     DS    A                   ADDR TO STUFF CCHH OF NEXT WS   DASD 79170000
TPERCY   DS    F                   TRACKS PER CYLINDER                  79300000
*                                  NOTE TPERWS AND TPERCY SHOULD BE     79430000
*                                  MULTIPLES.  (NOT A RESTRICTION, JUST 79560000
*                                  A SUGGESTION)                        79690000
XTR      EQU   *-C'0'                                                   79820000
         DC    C'0123456789ABCDEF'                                      79950000
         TITLE 'D S E C T S                                   05/11/70' 80080000
*                                                                       80210000
         LTORG                                                          80340000
*                                                                       80470000
*              PARAMETRIC CONTROL BLOCK FOR DISKFORMAT                  80600000
DKFMPAR  DSECT                                                          80730000
ISSWAP   DS    X                   0 = FORMAT ALTERNATE TRACKS          80860000
*                                  NON0 = SKIP BAD-TRACK AREAS          80990000
CDCBASE  DS    A(CDCPARS)                                               81120000
WSS      DS    F                   WORKSPACES TO BE FORMED IN SWAP AREA 81250000
*                                  IRRELEVANT IF ISSWAP = 0             81380000
PERDAD   DS    A                   START ADDR OF TABLE INTO WHICH TO    81510000
*                                  STUFF CCHH OF EACH WORKSPACE.   DASD 81640000
*                                  IRRELEVANT IF ISSWAP = 0             81770000
PERDINC  DS    F                   WIDTH OF PERDISK ENTRIES.            81900000
*                                  IRRELEVANT IF ISSWAP = 0             82030000
*                                                                       82160000
PERDISK  DSECT ,                   ONE PER DISK AREA                    82290000
PDDA     DS    F                                                   DASD 82420000
PDXTENT  EQU   *                                                   DASD 82550000
PDTERM   DS    X                                                        82680000
         DS    AL3 (PERTERM)       HIGH ORDER BIT MEANS UNASSIGNED      82810000
PERDISKL EQU   *-PERDISK                                                82940000
*                                                                       83070000
OPLIB    CSECT                                                          93210000
         IOBECBD                                                        93340000
         DCBD  DSORG=(DA)                                               93470000
         COPY  CDCPARS                                                  93730000
*                                                                       93860000
         COPY  DIRSECT                                                  93990000
         END                                                            94120000
./  ADD    NAME=APLSPCSB
PCSB     TITLE 'PROGRAM CHECK HANDLER AND FRIENDS             05/11/70' 00180000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00360000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00540000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00720000
PCSUB    CSECT                                                          01080000
         PRINT OFF                 COPY APLDEFN PERTERM ZSYMBOLS        01440000
         COPY  APLDEFN                                                  01620000
         COPY  PERTERM                                                  01800000
         COPY  ZSYMBOLS                                                 01980000
         PRINT ON,NOGEN                                                 02160000
         APLSUPC                                                        02340000
VALCON   EQU   1              AVOID ASSEMBLY ERROR                      02520000
PCSUB    CSECT                                                          02700000
         TITLE 'PROGRAM CHECK HANDLER AND FRIENDS             05/11/70' 02880000
         EXTRN DZERR                                                    03060000
         EXTRN ERROR                                                    03240000
         EXTRN LOUT                                                     03420000
         EXTRN LOUTN                                               2550 03600000
         EXTRN COPSINK             COPSINK IS IN APLSUP            2550 03780000
         EXTRN SUPPARS                                                  03960000
         EXTRN TYPEIN                                                   04140000
         EXTRN WSLEN                                                    04320000
         EXTRN DAYSUP                                                   04680000
         EXTRN SVOLDPSW                                                 04860000
         EXTRN TCBMERE                                                  05040000
*                                                                       05400000
*                                                                       05580000
*        PROGRAM CHECK HANDLER -- ENTERED FROM THE SUPERVISOR WHEN      05760000
*        AN APL PROGRAM CHECK OCCURS.                                   05940000
*                                                                       06120000
*        PROGRAM CHECK IN SUPERVISOR STATE TERMINATES APL               06300000
*                                                                       06480000
*        PROGRAM CHECK IN PROBLEM STATE..                               06660000
*                                                                       06840000
*        INTERRUPT CODE  ACTION                                         07020000
*                                                                       07200000
*        0     MODEL 91 IMPRECISE INT, REFORMAT AS 8-15                 07380000
*        1-7   DUMP CONSOLE AND PSW.                                    07560000
*        8-15  ON CONDITION.                                            07740000
*                                                                       07920000
*        NOTE THAT THE STORAGE KEY WILL BE THAT OF CURRENT M.           08100000
*                                                                       08280000
*                                                                       08460000
         USING  PCSUB,15           BASE REGISTER PROVIDED BY OS         10080000
         SR    0,0                 FOR MVT MODEL 91 SUPPORT.            10260000
         SPM   0                                                        10440000
         LR    0,1                 SAVE PIE POINTER                     10620000
         L     1,=A(SVOLDPSW)      GET ADDR. OF SVC OLD PSW IN APLSUP   10800000
         SVRAPE ,   THIS SHOULDN'T BE NEEDED, BUT LETS NOT TAKE CHANCES 10980000
         NC    0(2,1),=X'000F'     SET PSW TO DISABLE INTERRUPTS        11160000
*                                 AND A PROT.KEY OF 0                   11340000
         LR    1,0                 RESTORE PIE PTR. TO R1               11520000
         USING  PIE,1                                                   11700000
         STM   14,2,OSREGS         SVE OS REGISTERS.                    11880000
         LA    2,PCSAVAR                                                12060000
         USING SVEARA,2                                                 12240000
         STM   3,13,SVER03         SAVE PC REGS                         12420000
         MVC   SVER14(2*4),PIESR14 PC REGISTERS 14,15                   12600000
         MVC   SVER00(3*4),PIESR0  PC REGS 0-2.                         12780000
         MVC   SVEPSW1(8),PIEPSW   PC PSW. SAVED                        12960000
         L     1,=A(SUPPARS)                                            13140000
         L     MR,CURRENTM-SUPPARD(1)  CORRECT MR                       13320000
         ST    MR,SVER11           VERY IMPORTANT.                      13500000
         L     1,PTBASE-SUPPARD(1) IN CASE LOW END OF WS WAS CLOBERED,  13680000
         ST    1,MPTBASE           RESTORE MPTBASE                      13860000
*                                                                       14040000
*        DETERMINE INTERRUPT TYPE.                                      14220000
*                                                                       14400000
         TM    SVEPSW1+1,1         SEE IF WE WERE IN PROB. STATE.       14580000
         BO    NOTSUP              BRANCH IF SO.                        14760000
         ABEND 1290,DUMP,STEP POOF                                  K12 15660000
*                                                                       16020000
*        PROBLEM STATE PROGRAM CHECK.                                   16200000
*                                                                       16380000
NOTSUP   TM    SVEPSW2,X'C0'       ZERO INSTRUCTION LENGTH CODE         16560000
         BNZ   PRECISE             MEANS IMPRECISE INTERRUPT            16740000
*                                  OR CODE UNDER 8 ON A 65              16920000
         LA    1,7                 DECODE IMPRECISE INTERRUPT CODE      17100000
         LH    0,SVEPSW1+2         SET BY MODEL 91                      17280000
         N     0,=A(X'0FC0')       ALL PRECISE INTERRUPTS GET REG DUMP  17460000
         BZ    DUMPCONS                                                 17640000
         SLA   0,19                                                     17820000
PCTSTBIT LA    1,1(1)              COUNT TO FIRST 1 BIT                 18000000
         AR    0,0                                                      18180000
         BNO   PCTSTBIT                                                 18360000
         CH    1,=H'10'                                                 18540000
         BL    STPSW1                                                   18720000
         LA    1,2(1)              ADD 2 FOR OMITTED DECIMAL INTS       18900000
STPSW1   STH   1,SVEPSW1+2                                              19080000
PRECISE  CLI   SVEPSW1+3,7         CHECK FOR ON CONDITION TYPE          19260000
         BNH   DUMPCONS            NOT ON CONDITION, GO DUMP REGISTERS  19440000
*                                                                       19620000
*        ON-CONDITION INTERRUPT                                         19800000
*                                                                       19980000
ONCOND   LH    1,SVEPSW1+2                                              20160000
         SLL   1,3                 GET INT CODE TO                      20340000
         L     0,ONADRS(1)         LOCATE ON-CONDITION ADDRESS          20520000
         L     1,ONADRS+4(1)       AND SAVED RELATIVE LOCALS REGISTER   20700000
         LTR   0,0                 0 MEANS IGNORE                       20880000
         BNZ   PCS2                                                     21060000
         CLI   SVEPSW1+3,15        EXCEPT ZERO-DIVIDE, FOR WHICH 'IGNO- 21240000
         BNE   PCS3                RE' ISN'T QUITE ACCURATE.            21420000
         LTER  0,0                 ASSUME INTERRUPTED FROM SCOPS        21600000
         LD    0,QD1               IN WHICH WE WERE DOING F0 = F0/F2    21780000
         BZ    PCS3                0/0 GIVES 1.0                        21960000
         L     0,=A(DZERR)         OTHERWISE DEFAULT IS DOMAIN ERROR    22140000
PCS2     AR    1,MR                                                     22320000
         LM    4,7,SVER12          USE 48                               22500000
PCS5     CLR   5,1                 RUN BACK R13 STACK TO MATCHING R13   22680000
         BE    PCS6                                                     22860000
         BL    DUMPCONS                                                 23040000
         LM    4,7,0(5)                                                 23220000
         B     PCS5                                                     23400000
PCS6     IC    1,SVEPSW2           PUT NEW ADDRESS IN OLD PC PSW.       23580000
         ST    0,SVEPSW2           DON'T DISTURB PROGRAM MASK.          23760000
         STC   1,SVEPSW2                                                23940000
         STM   4,7,SVER12                                               24120000
PCS3     LM    14,1,OSREGS             RESTORE OS'S REGS.               25380000
         MVC   PIESR14(2*4),SVER14  NEW REG 14 & 15                     25560000
         MVC   PIEPSW(8),SVEPSW1                                        25740000
*        PREVIOUSLY WE USED SVRAPE TO GIVE THIS ROUTINE A PROT.         25920000
*        KEY OF ZERO AND DISABLE INTERRUPTS.                            26100000
*        NOW WE WANT TO RESTORE THE PSW TO THE STATE IT WAS IN          26280000
*        WHEN THE PROG. CHECK OCCURED - THAT IS, ITS ORIGINAL           26460000
*        PROT. KEY AND SYS. MASK                                        26640000
OSEXIT   L     5,=A(SVOLDPSW)          LOCATE ADDR OF SVC OLD PSW       26820000
         L     4,PIEPSW                GET FIRST WD. OF PROG. CHECK     27000000
         SVRAPE                        PSW AND PUT IT IN FIRST WD.      27180000
         ST    4,0(5)                  OF PSW TO RE RESTORED AFTER      27360000
*                                      THIS SVC INTERRUPT               27540000
         LM    3,13,SVER03         RESTORE PC'S REGISTERS               27720000
         L     2,OSREGS+4*4        RESTORE R2 FROM WHERE IT WAS SAVED   27900000
         BR    14                  TO OS.                               28080000
*                                                                       28440000
*        CONSOLE DUMP FOLLOWED BY                                       28620000
*        'SYSTEM ERROR'                                                 28800000
*                                                                       28980000
DUMPCONS L     LR,=A(WSLEN)        FIRST, GET SAVED REGISTERS INTO M.   29160000
         L     LR,0(LR)            RECOMPUTE BASE OF R13 STACK FROM     29340000
         S     LR,=A(LR13STK)      INFORMATION IN CONFIG                29520000
         ST    LR,QR13STK          MAKE SURE WORKSPACE COPY IS CORRECT  29700000
         AR    LR,MR                                                    29880000
         MVC   16(SVEFP0-SVER00,LR),SVER00 MOVE REGISTERS INTO M.       30060000
         MVC   80(8,LR),SVEPSW1    PSW.                                 30240000
*                                                                       32220000
*        ROUTINE TO LOCATE APL'S LOAD POINT IN CORE FOR CONSOLE DUMP    32400000
*                                                                       32580000
         L     7,=A(TCBMERE+8)     MOTHER PRB ADDRESS.                  32760000
         L     7,0(7)              MOTHER PRB.                          32940000
*                                                                   MFT 33120000
         L      1,CVTPTR                                            MFT 33300000
         USING CVTD,1                                               MFT 33480000
         TM    CVTDCB,MFT     NO CDE FOR MFT SYSTEMS                MFT 33660000
         BZ    MVTCDE         TEAR THE MVT CDE APART                MFT 33840000
         DROP  1                                                    MFT 34020000
*                                                                   MFT 34200000
*   THE LOAD MODULE IS NORMALLY JUST AFTER THE RB IN MFT            MFT 34380000
*                                                                   MFT 34560000
         TM    10(7),X'02'    IS THERE A PROGRAM EXTEND LIST?       MFT 34740000
         LA    7,32(7)        BUMP PAST BASIC LRP                   MFT 34920000
         BZ    RESTDUMP       IF NONE, 7 POINTS TO LOAD MODULE      MFT 35100000
         LR    1,7                                                  MFT 35280000
         L     7,8(1)         H0 ADDRESS                            MFT 35460000
         LTR   7,7                                                  MFT 35640000
         BNZ   RESTDUMP       PRINT OUT H0 ADDRESS                  MFT 35820000
         L     7,12(1)        H1 LOAD ADDRESS                       MFT 36000000
         LTR   7,7                                                  MFT 36180000
         BNZ   RESTDUMP       PRINT H1 ADDRESS                      MFT 36360000
         L     7,16(1)                                              MFT 36540000
         B     RESTDUMP                                             MFT 36720000
*                                                                   MFT 36900000
*    FIND LOAD ADDRESS OF APL360 LOAD MODULE FROM CDE/XL            MFT 37080000
*                                                                   MFT 37260000
MVTCDE   L     7,12(7)   ADDRESS OF CONTENTS DIRECTORY              MFT 37440000
         TM    0(7),4             TEST FOR MINOR CDE                    37620000
         BNO   MAJCDE             IF MAJOR CDE - BRANCH                 37800000
         L     7,20(7)            IF MINOR - GET ADDR. OF MAJOR CDE     37980000
MAJCDE   L     7,20(7)            PTR TO XL.                            38160000
         L     7,12(7)            LOAD PT OF APLPORT                    38340000
RESTDUMP ST    7,88(LR)           STORE LOAD PT. TO BE WRITTEN ON       38520000
*                                  ON USERS CONSOLE                     38700000
*                                                                       38880000
*        THE FOLLOWING MANEUVER IS REQUIRED TO ACHIEVE SOME SORT        39060000
*              OF RE-ENTRANCE FOR THE PROGRAM CHECK ROUTINE.            39240000
*                                                                       39420000
         LM    14,1,OSREGS         RESTORE OS'S REGISTERS               39600000
         USING PIE,1                                                    39780000
         MVC   PIEPSW+4(4),=A(PCRETURN)  OS WILL BRNCH TO REST OF PCSB  39960000
         L     5,=A(SVOLDPSW)          LOCATE ADDR OF SVC OLD PSW       40140000
         B     OSEXIT                                                   40320000
         DROP  15                                                       40500000
*                                                                       40860000
*        FORMAT AND OUTPUT CONSOLE DUMP TO USERS TERMINAL               41040000
*                                                                       41220000
PCRETURN BALR  9,0                                                      41400000
         USING *,9                                                      41580000
         L     LR,QR13STK          RESTORE LR.                          41760000
         AR    LR,MR                                                    41940000
         LA    TLR,104(LR)                                              42120000
         L     7,MPTBASE           ADDR OF CURRENT PERTERM         2550 42300000
         TM    IOB1-PERTERM(7),COPYWM  ARE WE A COPY SOURCE        2550 42480000
         BO    SN3                 BYPASS LOUT IF COPY SOURCE      2550 42660000
         CLC   OBUFPTR(2),=H'130'  FORCE OUT ANY REMAINING TEXT UNLESS  42840000
         BNL   SN3                 THE BUFFER POINTER LOOKS RIDICULOUS  43020000
         ICALL LOUT                PRINT THE GRS AND THE PC OLD PSW     43200000
*                                  ON THE USER'S TYPEWRITER             43380000
SN3      MVI   (92+4*1)(LR),ZBLANK*16-ZBLANK/16*255                     44280000
         LM    3,5,BXLR                                                 44640000
SN0      LA    6,OBUF+2                                                 44820000
         MVI   OBUF,ZBLANK                                              45000000
         MVC   OBUF+1(80),OBUF                                          45180000
SN1      L     1,16(3,LR)                                               45360000
         ST    1,(88+4*1)(LR)                                           46260000
         UNPK  0(9,6),(88+4*1)(5,LR)                                    47340000
         TR    0(8,6),TOHEX                                             47700000
         LA    6,10(6)                                                  47880000
         BXLE  3,4,SN1                                                  48060000
         BCTR  6,0                 R6 POINTS AT LAST HEX DIGIT + 2 2550 48240000
         MVC   0(2,6),EXS4         APPEND CR AND EOB               2550 48420000
         LA    1,OBUF-1            FIND LENGTH OF LINE             2550 48600000
         SR    6,1                                                      48780000
         STH   6,OBUFPTR                                                48960000
         TM    IOB1-PERTERM(7),COPYWM  ARE WE A COPY SOURCE        2550 49140000
         BZ    SN4                 BRANCH IF NOT COPY SOURCE       2550 49320000
         TCOM  LOG,OBUFPTR         SEND REG DUMP TO RECORD TERM    2550 49500000
         B     SN5                                                 2550 49680000
SN4      EQU   *                                                   2550 49860000
         ICALL LOUTN               PRINT REG DUMP ON USER TERM     2550 50040000
SN5      EQU   *                                                   2550 50220000
         LA    5,32(5)                                                  50400000
         C     5,SNET                                                   50580000
         BL    SN0                                                      50760000
         LA    5,71+4*1                                                 51660000
         BE    SN0                                                      52020000
         MVC   24(23+10,LR),OBUF   SAVE PSW, CR, AND EOB           2550 52920000
         L     2,=A(SUPPARS)                                            53280000
         LR    1,7                 R1 HAS ADDR OF PERTERM          2550 53460000
         TM    IOB1-PERTERM(7),COPYWM   IS THIS A COPY SOURCE      2550 53640000
         BZ    *+12                BRANCH IF NOT A COPY SOURCE     2550 53820000
         L     1,=A(COPSINK)       GET ADDR OF SINK'S              2550 54000000
         L     1,0(1)               PERTERM.                       2550 54180000
         S     1,PTBXLE+8-SUPPARD(2)                                    54360000
         SR    0,0                                                      54540000
         D     0,PTBXLE-SUPPARD(2) COMPUTE PORT NUMBER                  54720000
         CVD   1,16(LR)                                                 54900000
         UNPK  OBUF(5),22(3,LR)                                         55080000
         TR    OBUF(3),TOHEX       CONVERT TO ZSYMBOLS                  55260000
         MVC   OBUF+3(EXS4-EXS3+1),EXS3-1   ' SYSTEM ERROR'             55440000
         MVC   OBUF+4+EXS4-EXS3(23+10),24(LR)  MOVE IN PSW, CR, EOB2550 56340000
         MVI   OBUFPTR+1,26+10+EXS4-EXS3  MOVE IN LENGTH           2550 57420000
         TCOM  LOG,OBUFPTR         TELL OPERATOR ABOUT SYSTEM ERROR     57780000
         TM    IOB1-PERTERM(7),COPYWM  ARE WE A COPY SOURCE        2550 57960000
         BZ    PCSWITCH            BRANCH IF NOT A COPY SOURCE     2550 58140000
         MVC   OBUF(3),=AL1(Z0,Z0,Z0)  SEND '000 SYSTEM ERROR      2550 58320000
         ICALL LOUTN                 PSW' TO SINK                  2550 58500000
         TYI   ,                   THIS ENDS COPY SOURCE           2550 58680000
PCSWITCH BC    0,SN2                                                    58860000
         MVI   OBUFPTR+1,EXS4-EXS3 LENGTH OF SYSTEM ERROR MESSAGE       59040000
         MVC   OBUF(EXS4-EXS3),EXS3  MOVE IN SYSTEM ERROR MESSAGE       59220000
         ICALL LOUT                OUTPUT MESSAGE                       59400000
         LEMP                    , LOAD EMPTY WORKSPACE.                59580000
         ENTRY PCSWITCH                                                 59760000
SN2      LA    1,ESYSTEM                                                59940000
         MVI   OBUFPTR+1,0         CLEAR OBUFPTR FOR ERROR ROUTINE 2550 60120000
         ICALL ERROR                                                    60300000
         DROP  9                                                        60480000
*                                                                       60660000
*                                                                       63180000
*                                                                       63360000
*                                                                       63540000
         ENTRY BGATTN                                                   63720000
BGATTN   LA    0,ONATTN            GUARANTEED RECOGNITION OF ATTENTION  63900000
*              NOTES ...           THIS REALLY IS A FAKED 'SIGNAL'      64080000
*                                  EXPANSION.  IF WE GET HERE, ONATTN   64260000
*                                  IS GUARANTEED NONZERO.  APLSUP DOES  64440000
*                                  THE RECOGNITION OF INHIBITED BGATTN  64620000
*                                  FOR US BECAUSE WE WOULD HAVE NO WAY  64800000
*                                  TO GET BACK TO INTERRUPTEE ON        64980000
*                                  INHIBITED INTERRUPT.                 65160000
*                                                                       65340000
*                                                                       65520000
*                                                                       65700000
         ENTRY SIGNAL                                                   65880000
SIGNAL   STM   0,15,16(TLR)        ON-CONDITION SIMULATED INTERRUPT.    66060000
         LR    10,TLR              PRESERVE CURRENT LR TO FIND REGISTER 66240000
         BALR  2,0                 ***** BYPASSES LINKAGE MACROS *****  66420000
         USING *,2                                                      66600000
         LR    1,0                 GET ON-INFO ADDRESS IN R1            66780000
         L     0,4(1)              RECALL RELATIVE LR                   66960000
         AR    0,MR                                                     67140000
SIG2     CR    LR,0                WEND DOWN THE SAVE AREAS UNTIL       67320000
         BE    SIGR                WE FIND A MATCHING LR.               67500000
         BL    DUMPCON2            IF PAST, DISASTER.  SOMEONE FORGOT   67680000
*                                  TO DISABLE THE ON-CONDITION.         67860000
         LM    12,15,0(LR)         RECALL NEXT REGISTER-SAVE GROUP      68040000
         B     SIG2                                                     68220000
SIGR     L     1,0(1)              RECALL ADDRESS OF ON BLOCK           68400000
         LM    2,11,2*4+16(10)     RESTORE REGISTERS                    68580000
         BR    1                   AND TAKE ON-CONDITION.               68760000
DUMPCON2 L     LR,QR13STK                                               68940000
         AR    LR,MR                                                    69120000
         MVC   16(16*4,LR),16(10)  MOVE REGISTERS SO PCRETURN WILL FIND 69300000
         XC    16+16*4(8,LR),16+16*4(LR)   ZERO PSW                     69480000
         L     10,=A(PCRETURN)     GO DUMP CONSOLE                      69660000
         BR    10                                                       69840000
*                                                                       70020000
*        PRINT MESSAGE AFTER RELOC (APLSUP) FOUND ERROR THAT THE        70200000
*        R13, R14 STACK HAS BEEN LOST                                   70380000
*                                                                       70560000
         ENTRY EREXSUP                                                  70740000
EREXSUP  BALR  5,0                                                      70920000
         USING *,5                                                      71100000
         TYO   EXS1                PRINT ERROR MESSAGE                  71280000
         ICALL TYPEIN              WHICH NEVER RETURNS                  71460000
EXS1     DC    Y(EXS2-*-3)                                              71640000
         DC    AL1(ZR,Z1,Z3,ZBLANK)                                     71820000
EXS3     DC    AL1(ZS,ZY,ZS,ZT,ZE,ZM,ZBLANK,ZE,ZR,ZR,ZO,ZR)             72000000
EXS4     DC    AL1(ZCR,ZEOB)                                            72180000
EXS2     EQU   *                                                        72360000
         DROP  5                                                        72540000
*                                                                       72720000
*        CONVERT DIRECTORY INTO CLEAR WS WITH MESSAGE TO TERMINAL       72900000
*                                                                       73080000
         ENTRY NEWWS                                                    73260000
NEWWS    BALR  12,0                                                     73440000
         USING *,12                                                     73620000
         BAL   LKR,DIREMP          RESET MX AND SVI                     73800000
         TYO   DTXT                                                     73980000
         ICALL TYPEIN              WHICH NEVER RETURNS                  74160000
         DROP  12                                                       74340000
*                                                                       74520000
*        CONVERT DIRECTORY INTO CLEAR WS                                74700000
*                                                                       74880000
         ENTRY DIREMP                                                   75060000
DIREMP   PROLOG                                                         75240000
         LA    1,FREE-M            SET UP MX,                           75420000
         ST    1,MX                                                     75600000
         ST    1,MING                                                   75780000
         L     1,QSYMBOT           SVI,                                 75960000
         S     1,=A(STPARAM+8-STFREG)                                   76140000
         ST    1,SVI                                                    76320000
         LA    1,4(1)              AND PARREL.                          76500000
         ST    1,PARREL                                                 76680000
         AR    1,MR                                                     76860000
         XC    0(STPARAM+4-STFREG,1),0(1)  AND INITIALIZE BOTTOM OF STK 77040000
         MVI   STFLAGS(1),STIMBIT                                       77220000
         IRETURN                                                        77400000
*                                                                       77580000
DTXT     DC    Y(DTXTZ-*-3)                                             77760000
         DC    AL1(ZC,ZL,ZE,ZA,ZR,ZBLANK,ZW,ZS,ZCR,ZEOB)                77940000
DTXTZ    EQU   *                                                        78120000
*                                                                       78300000
*              GETIME -- GET TIME OF DAY (300 TH SECOND) INTO R1        78480000
*                                                                       78660000
         ENTRY GETIME                                                   78840000
GETIME   PROLOG GETIMEL,GETIMELZ                                        80820000
         STM   14,0,GETIMEL        SAVE 14,15,0.                        81000000
         TIME  TU                  OS TIME OF DAY IN R0.                81180000
         LR    1,0                 MOVE TO R1.                          81360000
         SRL   1,7                 CONVERT TO REASONABLE UNITS.         81540000
         L     2,=A(DAYSUP)        GET NUMBER OF DAYS SINCE INITIATION. 81720000
         A     1,0(2)              FROM APLSUP, ADD TO T.O.D.           81900000
         L     2,=A(SUPPARS+(REALTIME-SUPPARD)) LOOK AT APLSUP'S TOD    82080000
         C     1,0(2)  IF OUT TOD LT REALTIME, ASSUME MIDNIGHT. APLSUP  82260000
*                                  WILL RESOLVE SHORTLY.                82440000
         BNL   *+8                 BRANCH IF NOT.                       82620000
         L     1,0(2)              PROBABLY NOT MIDNIGHT.               82800000
         LM    14,0,GETIMEL                                             82980000
         IRETURN                                                        83160000
*                                                                       83340000
*        DSECT FOR GETIME.                                              83520000
*                                                                       83700000
GETIMEL  DSECT                                                          83880000
         DS    3F                                                       84060000
GETIMELZ EQU   *                                                        84240000
*                                                                       84420000
CVTD     DSECT                                                      MFT 84600000
MFT      EQU   X'20'                                                MFT 84780000
         CVT   SYS=MFT                                              MFT 84960000
PCSUB    CSECT                                                          86040000
*                                                                       86220000
*              PROGRAM CHECK SAVE AREA                                  86400000
*                                                                       86580000
         ENTRY PCSAVAR                                                  86760000
PCSAVAR  DC    D'0',16F'0'         SAVE AREA                            86940000
*                                                                       87120000
*        CONSTANTS                                                      87300000
*                                                                       87480000
QD1      DC    D'1'                                                     87660000
OSREGS   DS    5F                  REG SAVEAREA FOR REGS 14-1           88740000
K24HOURS DC    F'25920000'                                              88920000
         LTORG                                                          89280000
*                                                                       89460000
BXLR     DC    F'0,4,31'                                                89640000
SNET     DC    F'95'                                                    89820000
TOHEX    EQU   *-C'0'                                                   90000000
         DC    AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZA,ZB,ZC,ZD,ZE,ZF)     90180000
*                                                                       90360000
*        SAVE AREA DESCRIPTION                                          90540000
*                                                                       90720000
SVEARA   DSECT                                                          90900000
SVEPSW1  DS    0CL8                                                     91080000
         DS    CL4                                                      91260000
SVEPSW2  DS    CL4                                                      91440000
SVER00   DS    CL4                                                      91620000
SVER01   DS    CL4                                                      91800000
SVER02   DS    CL4                                                      91980000
SVER03   DS    CL4                                                      92160000
SVER04   DS    CL4                                                      92340000
SVER05   DS    CL4                                                      92520000
SVER06   DS    CL4                                                      92700000
SVER07   DS    CL4                                                      92880000
SVER08   DS    CL4                                                      93060000
SVER09   DS    CL4                                                      93240000
SVER10   DS    CL4                                                      93420000
SVER11   DS    CL4                                                      93600000
SVER12   DS    CL4                                                      93780000
SVER13   DS    CL4                                                      93960000
SVER14   DS    CL4                                                      94140000
SVER15   DS    CL4                                                      94320000
SVEFP0   DS    CL8                                                      94500000
SVEFP2   DS    CL8                                                      94680000
SVEFP4   DS    CL8                                                      94860000
SVEFP6   DS    CL8                                                      95040000
*                                                                       95220000
*                                                                       95580000
*                                                                       95760000
*                                                                       95940000
PIE      DSECT                                                          96120000
PICA     DS    A                                                        96300000
PIEPSW   DS    2A                                                       96480000
PIESR14  DS    F                                                        96660000
PIESR15  DS    F                                                        96840000
PIESR0   DS    F                                                        97020000
PIESR1   DS    F                                                        97200000
PIESR2   DS    F                                                        97380000
         END                                                            97560000
./  ADD    NAME=APLSRAVL
RAVL     TITLE 'R A V E L   T O   V E C T O R                 05/11/70' 01380000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02760000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  04140000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       05520000
         PRINT OFF       APLDEFN, OPSECT                                08280000
EXRAVEL CSECT                                                           09660000
         COPY  APLDEFN                                                  11040000
         COPY  OPSECT                                                   12420000
         TITLE 'R A V E L   T O   V E C T O R                 05/11/70' 13800000
         PRINT ON,NOGEN                                                 15180000
EXRAVEL CSECT                                                           16560000
         USING *,9                                                      17940000
         USING OPSECT-16,LR                                             19320000
*                                                                       20700000
*        THIS OPERATOR MAKES A RHXRHO LONG VECTOR OUT OF ANYTHING.      22080000
*                                                                       23460000
         SPACE                                                          24840000
         ST    LKR,CURRES          SAVE THE LINK.                       26220000
         L     1,RHXRHO            FIRST, WE GET SPACE.                 27600000
         SPACE                                                          28980000
         LA    2,4                 MAKE RANK - VECTOR.                  30360000
         L     3,RHTYPE            PICK UP OPERAND TYPE.                31740000
         L     10,=A(OPSPACE)      PICK UP ENTRY TO COMMON GETSPACE.    33120000
         BALR  LKR,10              AND ENTER IT.                        34500000
         SPACE                                                          35880000
*                                                                       37260000
*        NOW, SET UP HEADING.                                           38640000
*                                                                       40020000
         LA    2,4                 THE RANK WILL BE 4.                  41400000
         STH   2,MRANK(1)          STORED.                              44160000
         L     2,RHTYPE            TYPE.                                45540000
         STC   2,MTYPE(1)          STORED.                              48300000
         L     4,RHXRHO            PICK UP RIGHT LENGTH.                49680000
         ST    4,MRHO(1)           STORE AS RANK OF RESULT.             51060000
*                                                                       52440000
*        NOW, MOVE IN ELEMENTS.                                         53820000
*                                                                       55200000
         SPACE                                                          56580000
         L     4,MCOUNT(1)         GET BYTE COUNT FOR RESULT ELEMENTS.  57960000
         S     4,=A(MRHO-M+4)      BY SUBTRACTING HEAD LENGTH FROM COUN 59340000
         BNP   DONE                BRANCH IF OPERAND IS EMPTY VECTOR.   60720000
         SPACE                                                          62100000
         LA    8,MRHO+4(1)         USE ABSOLUTE RESULT POINTER.         63480000
         L     7,RHBASE                                                 64860000
         LA    7,MRHO(7)                                                66240000
         A     7,RHRANK            AND RIGHT POINTER.                   67620000
         LA    2,255               MAXIMUM MOVE COUNT.                  69000000
         LA    3,256               MAXIMUM MOVE LENGTH.                 70380000
         BCTR  4,0                 DECREMENT RESULT COUNT BY 1.         71760000
         SPACE                                                          73140000
MVCLOOP  CR    4,3                 SEE IF THERE LESS THAN 256 BYTES.    74520000
         BL    LASTMOVE            BRANCH IF SO.                        75900000
         EX    2,MOVER             OTHERWISE, MOVE 256 BYTES.           77280000
         AR    8,3                 INCREMENT POINTERS.                  78660000
         AR    7,3                                                      80040000
         SR    4,3                 DECREMENT RH COUNT.                  81420000
         B     MVCLOOP             AND TRY AGAIN.                       82800000
         SPACE                                                          84180000
LASTMOVE EX    4,MOVER             REMOVE REMAINING OPERAND.            85560000
         SPACE                                                          86940000
DONE     L     LKR,CURRES          PICK UP LINK.                        88320000
         BR    LKR                 AND DEPART.                          89700000
         SPACE                                                          91080000
MOVER    MVC   0(0,8),0(7)                                              92460000
         DC    0F'0'                                                    93840000
         EXTRN OPSPACE                                                  95220000
         LTORG                                                          96600000
         END                                                            97980000
./  ADD    NAME=APLSROTR
ROTR     TITLE 'R O T A T I O N   A N D   R E V E R S A L     05/11/70' 00250000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00500000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00750000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01000000
         PRINT OFF       APLDEFN, ZSYMBOLS, OPSECT                      01500000
SCNSETUP CSECT                                                          01750000
         COPY  APLDEFN                                                  02000000
         COPY  ZSYMBOLS                                                 02250000
         COPY  OPSECT                                                   02500000
         PRINT ON,NOGEN                                                 02750000
OPSECT   DSECT                                                          03000000
         ORG   BINOSAVE                                                 03250000
CLOSS    DS    F                                                        03500000
DIF      DS    F                                                        03750000
DX       DS    F                                                        04000000
ELEMS    DS    F                                                        04250000
EMU      DS    F                                                        04500000
HIPROD   DS    2F                                                       04750000
LHFINCR  DS    F                                                        05000000
LOPROD   EQU   HIPROD+4                                                 05250000
ORX      DS    F                                                        05500000
RA       DS    2F                                                       05750000
REALINDX DS    F                                                        06000000
ROORET   DS    F                                                        06250000
SAVED    DS    2F                                                       06500000
SCNRET   DS    F                                                        06750000
SINCR    DS    2F                                                       07000000
SX       DS    F                                                        07250000
TRIV     DS    F                                                        07500000
         ORG                                                            07750000
         EXTRN ERROR                                                    08000000
         EXTRN FETCH                                                    08250000
         EXTRN FETCHINT                                                 08500000
         EXTRN STORE                                                    08750000
         EXTRN OPSPACE                                                  09000000
     TITLE    'I N I T A L I Z A T I O N   F O R   V E C T O R  O P S'  09250000
SCNSETUP CSECT                                                          09500000
*                                                                       09750000
*   CALLED BY ROTATE AND REVERSAL FOR INITALIZATION.  GETS SPACE        10000000
*        FOR ANSWER OR SETS UP TO DO OPERATION IN PLACE.                10250000
*        CALCULATES SUNDRY MAGIC NUMBERS.                               10500000
*                                                                       10750000
         USING OPSECT-16,LR                                             11000000
         USING *,8                                                      11250000
         ST    LKR,SCNRET                                               11500000
         MVI   TRIV+3,0            TRIV=0 MEANS TRIVIAL                 11750000
         CLI   TEMPRGT,0           IS RH ARG TEMP9                      12000000
         BNE   OVWT                YES.  WE'LL USE SAME SPACE FOR RESLT 12250000
         L     1,RHXRHO            OTHERWISE, RESERVE SPACE             12500000
         L     2,RHRANK                                                 12750000
         L     3,RHTYPE                                                 13000000
         L     10,=A(OPSPACE)                                           13250000
         BALR  LKR,10                                                   13500000
         L     LKR,SCNRET          MAY EXIT ANY TIME NOW                13750000
         L     2,RHBASE                                                 14000000
         ST    1,RHBASE            SAVE RESULT BASE.  PREPARE FOR MOVE  14250000
         AR    1,MR                R1  ABSOLUTE PTR FOR RESULT          14500000
         L     5,MCOUNT(2)                                              14750000
         AR    2,MR                R2  ABSOLUTE PTR FOR RH ARG          15000000
         LA    4,256                                                    15250000
         SR    3,3                                                      15500000
         S     5,=F'8'             DON'T MOVE FIRST 2 WORDS             15750000
         BCT   5,MV2                                                    16000000
EXMV     MVC   8(0,1),8(2)         PICK UP LAST FEW BYTES               16250000
MV       MVC   8(256,1),8(2)                                            16500000
         AR    1,4                                                      16750000
         AR    2,4                                                      17000000
MV2      BXLE  3,4,MV                                                   17250000
         EX    5,EXMV              COMPLETING THE MOVE                  17500000
         B     COMP                                                     17750000
OVWT     MVI   TEMPRGT,0           OVERWRITE RIGHT ARG IN TEMP CASE     18000000
         L     1,SVI               CALL IT THE RESULT (BY STACKING IT   18250000
         L     3,INCR              WHERE THE RESULT SHOULD BE)          18500000
         AR    3,1                                                      18750000
         L     2,M(3)              RARG STACK ENTRY                     19000000
         ST    2,M(1)                                                   19250000
         ST    1,M(2)                                                   19500000
         SR    0,0                                                      19750000
         ST    0,M(3)                                                   20000000
         S     1,=F'4'                                                  20250000
         ST    1,SVI                                                    20500000
COMP     L     10,RHBASE                                                20750000
         LR    1,10                COMPUTE RHORG                        21000000
         A     1,RHRANK                                                 21250000
         LA    1,MRHO-M(1)                                              21500000
         ST    1,RHORG                                                  21750000
         MVC   RCFTYPE,RHTYPE      & SET UP RCFTYPE                     22000000
         AR    10,MR               R10  ABSOLUTE PTR TO RESULT          22250000
         LA    7,1                 R7  X/HIGH DIMENSIONS                22500000
         LR    1,7                 R1  X/LOW DIMENSIONS                 22750000
         ST    7,SINCR+4                                                23000000
         SR    4,4                 R4  INDEX THROUGH RHO S              23250000
         L     3,RHRANK            R3  RHRANK                           23500000
         TM    INDBASE,X'C0'       IS AN INDEX SUPPLIED                 23750000
         BO    INDEXER             YES BUT ITS FRACTIONSL               24000000
         BM    LINDXX              YES.SO USE IT                        24250000
         SR    5,5                 ASSUME COLUMN OPERATION              24500000
         CLI   OPERATOR+3,1+2*ZCOLREV                                   24750000
         BE    CHIX                ACT ON LEFTMOST COORDINATE           25000000
         LR    5,3                 IMPLICIT.  MAKE EQUAL TO LAST        25250000
         S     5,=F'4'               DIMENSION                          25500000
         BNM   STORIX              AND SKIP OUT-OF-RANGE TEST           25750000
         BR    LKR                 NULL VECTOR                          26000000
LINDXX   L     5,INDEX                                                  26250000
         SLA   5,2                 R5  INDEX X 4, 0 ORIGIN              26500000
CHIX     CLR   3,5                 INDEX GT RANK ISN'T AN ERROR         26750000
         BCR   13,LKR              BUT TRAP IT AS TOO EASY              27000000
STORIX   ST    5,REALINDX          MAY BE USEFUL                        27250000
DOHIPROD CR    4,5                                                      27500000
         BNL   GOTHIPR                                                  27750000
         M     6,MRHO-M(4,10)                                           28000000
         LA    4,4(4)                                                   28250000
         B     DOHIPROD                                                 28500000
GOTHIPR  LTR   7,7                                                      28750000
         BCR   8,LKR               0 HIGH DIMENSION TRIVIAL RETURN      29000000
         ST    7,HIPROD                                                 29250000
         L     2,MRHO-M(5,10)       GET MU, THE SPECIFIED DIMENSION     29500000
         LTR   2,2                 (HIGH AND LOW DIMENSIONS REFER TO    29750000
*                                   THOSE TO THE LEFT AND RIGHT OF MU)  30000000
         BCR   8,LKR               0 MU TRIVIAL RETURN                  30250000
DOLOPROD LA    5,4(5)                                                   30500000
         CR    5,3                                                      30750000
         BNL   GOTLOPR                                                  31000000
         M     0,MRHO-M(5,10)                                           31250000
         B     DOLOPROD                                                 31500000
GOTLOPR  LTR   10,1                                                     31750000
         BCR   8,LKR               0 LO DIMENSION TRIVIAL RETURN        32000000
         ST    1,LOPROD                                                 32250000
         MR    0,2                                                      32500000
         ST    1,EMU               EMU=X/SPECIFIED&LOWER DIMENSIONS     32750000
         SR    1,10                                                     33000000
         ST    1,DIF                                                    33250000
         LA    1,1(1)                                                   33500000
         ST    1,SINCR                                                  33750000
         SR    4,4                                                      34000000
         ST    4,RA                                                     34250000
         ST    4,SX                                                     34500000
         LA    3,1                                                      34750000
         SR    4,3                                                      35000000
         ST    4,RA+4                                                   35250000
         ST    4,ORX                                                    35500000
         ST    4,TRIV              TRIV NE 0 MEANS NOT TRIVIAL          35750000
         BR    LKR                                                      36000000
INDEXER  LA    1,EINDEX            FRACTIONAL INDEX NOT ALLOWED         36250000
         ICALL ERROR                                                    36500000
         LTORG                                                          36750000
         TITLE 'N E X T  V E C T O R'                                   37000000
NEXTVECT CSECT                                                          37250000
         USING *,8                                                      37500000
         LA    1,4                 R1  K                                37750000
TEST     L     2,RA(1)             INCREMENT RA(K)                      38000000
         LA    2,1(2)                                                   38250000
         ST    2,RA(1)                                                  38500000
         C     2,HIPROD(1)         HIPROD OR LOPROD                     38750000
         BL    GOAHEAD             MEANING S(RA,,RA(1)) IS THE DESIRED  39000000
         LTR   1,1                         VECTOR                       39250000
         BCR   8,LKR               RETURN CC = IF NO MORE VECTORS       39500000
         SR    1,1                                                      39750000
         ST    1,RA+4                                                   40000000
         B     TEST                                                     40250000
GOAHEAD  L     2,SINCR(1)                                               40500000
         A     2,ORX               R2  INDEX OF NEXT VECTOR             40750000
         ST    2,ORX                                                    41000000
         CR    1,LKR                                                    41250000
         BR    LKR                 WITH CC SET NE BECAUSE THERE IS      41500000
*                                       A VECTOR                        41750000
         LTORG                                                          42000000
         TITLE 'R O T A T E  --  A L L   C A S E S'                     42250000
EXDCIRSL CSECT                                                          42500000
         USING *,9                                                      42750000
         ST    LKR,ROORET                                               43000000
*   SAVE A LITTLE TIME IN A SPECIAL CASE                                43250000
         CLI   RHTYPE+3,1          WE'RE LOOKING                        43500000
         BE    BOOLORNV                 FOR A                           43750000
         L     3,RHTYPE                                                 44000000
         L     2,RHRANK                 NON-BOOLEAN                     44250000
         C     2,=F'4'                                                  44500000
         BNE   BOOLORNV                 VECTOR                          44750000
         L     1,RHXRHO            GOT ONE. GET SPACE FOR RESULT        45000000
         LR    7,1                 R7  X/RHO                            45250000
         LR    5,2                 R5  RANK  (ONE)                      45500000
         LR    6,3                 R6  TYPE  (GTR 1)                    45750000
         L     10,=A(OPSPACE)                                           46000000
         BALR  LKR,10                                                   46250000
         STH   5,MRANK(1)                                               46500000
         STC   6,MTYPE(1)                                               46750000
         ST    7,MRHO(1)                                                47000000
         LA    5,MRHO+4(1)         R5  ABSOLUTE RESORG                  47250000
         CLI   LHSCALAR,0          OTHERWISE, CHECK FOR SCALAR          47500000
         BE    RANKERR                LEFT OP                           47750000
         L     4,LHBASE               AND GET ITS VALUE                 48000000
         A     4,LHRANK                                                 48250000
         LA    4,MRHO-M(4)                                              48500000
         L     3,LHTYPE                                                 48750000
         SR    2,2                                                      49000000
         ICALL FETCHINT                                                 49250000
         L     1,=F'-1'                                                 49500000
         MR    0,0                 R1  RIGHT ROTATE                     49750000
         L     10,RHXRHO                                                50000000
         LTR   10,10                                                    50250000
         BE    ROTEND              NULL ARGUMENT                        50500000
         DR    0,10                                                     50750000
         LR    1,10                                                     51000000
         LTR   0,0                                                      51250000
         BNL   *+6                                                      51500000
         AR    0,1                 R0  AMOUNT OF RIGHT SHIFT            51750000
         IC    6,SHFCT-2(6)        CONVERT TO CHARACTERS                52000000
         SLDL  0,0(6)                                                   52250000
         SR    1,0                 R1  AMT OF LEFT SHIFT                52500000
         LR    10,0                R10  TEMP STORE                      52750000
         LA    0,256               R0  MVC INCREMENT                    53000000
         SR    2,2                 R2  COUNT OF CHARS MOVED             53250000
         L     3,RHBASE                                                 53500000
         LA    3,MRHO+4(3)         R3  ABS PTR FOR RH ORG               53750000
         LA    6,0(3,1)            R6  ABS PTR FOR SOURCE OF 2ND MOVE   54000000
         LA    4,0(5,10)           R4  ABS PTR FOR DEST OF FIRST MOVE   54250000
         BCT   1,MVLEFT                                                 54500000
         B     EXLFMV              LEFT SHIFT BY 1 OF CHARACTER VECTOR  54750000
MAUVEL   MVC   0(256,4),0(3)       FIRST MOVE IS INIT SEG OF RH ARG     55000000
         AR    3,0                                                      55250000
         AR    4,0                                                      55500000
MVLEFT   BXLE  2,0,MAUVEL                                               55750000
EXLFMV   EX    1,MEVL                                                   56000000
         SR    2,2                 FIRST MOVE COMPLETED.                56250000
         LTR   1,10                NOW DO OTHER MOVE                    56500000
         BE    ROTEND              UNLESS SHIFT WAS NULL                56750000
         BCT   1,MVRGT                                                  57000000
         B     EXRGMV              SINGLE CHARACTER RIGHT SHIFT         57250000
MAUVER   MVC   0(256,5),0(6)                                            57500000
         AR    5,0                                                      57750000
         AR    6,0                                                      58000000
MVRGT    BXLE  2,0,MAUVER                                               58250000
EXRGMV   EX    1,MEVR                                                   58500000
         B     ROTEND              DONE, SO QUIT                        58750000
MEVL     MVC   0(0,4),0(3)                                              59000000
MEVR     MVC   0(0,5),0(6)                                              59250000
*   ORDINARY OLD CASE                                                   59500000
BOOLORNV L     8,=A(SCNSETUP)                                           59750000
         BALR  LKR,8                                                    60000000
         L     4,LHBASE                                                 60250000
         LR    5,4                 R5  LHBASE                           60500000
         L     8,LHRANK            SET UP LH FETCHINT ARGS              60750000
         LA    4,MRHO-M(4,8)       R8  LHRANK                           61000000
         ST    4,LHORG                                                  61250000
         L     3,LHTYPE                                                 61500000
         ST    3,LCFTYPE                                                61750000
         LA    2,1                                                      62000000
         ST    2,LHFINCR                                                62250000
         XC    LHFINCR+3(1),LHSCALAR                                    62500000
         BE    TRIVCHEK                                                 62750000
         AR    5,MR                CHECK THAT (RHO RHO L)=              63000000
         L     6,RHBASE             (-EPSI(I))/RHO RHO S.               63250000
         AR    6,MR                R5, R6  ABS PTRS TO LH AND RH ARGS   63500000
         L     3,RHRANK            R3, R8  RH, LH DIM INDEX             63750000
         L     4,REALINDX          R4  INDEX OF DIM TO SKIP COMPARE     64000000
         LA    7,4                 R7  DECREMENT                        64250000
         SR    1,1                 R1  LENGTH ERR SWITCH                64500000
COMPDIMS SR    3,7                                                      64750000
         BM    DIMSCHKD                                                 65000000
         CR    3,4                                                      65250000
         BE    COMPDIMS                                                 65500000
         SR    8,7                                                      65750000
         BM    RANKERR                                                  66000000
         L     0,MRHO-M(8,5)                                            66250000
         C     0,MRHO-M(3,6)                                            66500000
         BE    COMPDIMS                                                 66750000
         LA    1,ELENGTH                                                67000000
         B     COMPDIMS                                                 67250000
RANKERR  LA    1,ERANK                                                  67500000
         ICALL ERROR                                                    67750000
DIMSCHKD LTR   8,8                                                      68000000
         BNE   RANKERR                                                  68250000
         LTR   1,1                                                      68500000
         BE    TRIVCHEK                                                 68750000
         ICALL ERROR                                                    69000000
TRIVCHEK CLI   TRIV+3,0                                                 69250000
         BE    ROTEND                                                   69500000
*PRELIMINARIES NOW DISPENSED WITH.  GET VECTORS ONE AT A TIME           69750000
*  AND ROTATE THEM IN PLACE.                                            70000000
NEXTONE  L     8,=A(NEXTVECT)                                           70250000
         BALR  LKR,8                                                    70500000
         BE    ROTEND              NO MORE VECTORS                      70750000
         LM    3,4,LCFTYPE                                              71000000
         L     2,SX                                                     71250000
         ICALL FETCHINT                                                 71500000
         A     2,LHFINCR                                                71750000
         ST    2,SX                                                     72000000
         SRDA  0,32                                                     72250000
         M     0,LOPROD            R1 DISTANCE TO MOVE LEFT             72500000
         L     7,EMU               COMPUTE DX GCD EMU                   72750000
         LR    5,7                 R5  SAVE EMU FOR ELEMS CALC          73000000
         DR    0,7                 REDUCE DX MOD EMU                    73250000
         LTR   1,0                 PUT IT IN THE RIGHT REG FOR GCD      73500000
         BP    NEGATE                CALCULATION.                       73750000
         BM    POSATE              CHANGE TO RIGHT ROTATION             74000000
         QUEND                     NULL ROTATE. DON'T DO IT, BUT        74250000
         B     NEXTONE                  SOMEONE HAS TO QUEND            74500000
POSATE   AR    1,7                 MAKING A POSITIVE LEFT ROTATION      74750000
NEGATE   LNR   1,1                 A NEGATIVE RIGHT ROTATION            75000000
         ST    1,DX                                                     75250000
GCDLP    SR    6,6                                                      75500000
         DR    6,1                                                      75750000
         LPR   7,1                                                      76000000
         LTR   1,6                 IF NEXT DIVIDE WOULD BE BY 0,        76250000
         BNE   GCDLP                 THEN THE REQUIRED GCD              76500000
GCDFUND  ST    7,CLOSS               IS NOW IN R7                       76750000
         SR    4,4                                                      77000000
         DR    4,7                 ELEMS=(EMU./.CLOSS)-1.  -1 BECAUSE   77250000
         BCT   5,STELEMS                LAST ITEM OF CYCLE IS HANDLED   77500000
STELEMS  ST    5,ELEMS                  SPECIALLY                       77750000
         LM    3,4,RCFTYPE                                              78000000
         L     5,ORX               R5  ORX                              78250000
         L     10,CLOSS                                                 78500000
CLASSLP  S     10,LOPROD           R10  RX                              78750000
         BM    NEXTONE                                                  79000000
         ST    10,CLOSS                                                 79250000
         LR    2,5                                                      79500000
         AR    2,10                R2  RX+ORX                           79750000
         ICALL FETCH                                                    80000000
         STM   0,1,SAVED                                                80250000
         LDR   2,0                                                      80500000
         L     8,ELEMS             R8  T--INNER LOOP COUNTER            80750000
MOVELP   L     2,DX                                                     81000000
         AR    2,10                                                     81250000
         BNL   POSRES                                                   81500000
         A     2,EMU                                                    81750000
POSRES   LR    10,2                NEXT RX IS THIS FORD RX              82000000
         AR    2,5                                                      82250000
         ICALL FETCH                                                    82500000
         LR    6,0                 R6, R7  TEMPFORWD                    82750000
         LDR   4,0                                                      83000000
         LDR   0,2                                                      83250000
         LDR   2,4                                                      83500000
         LR    7,1                                                      83750000
         LM    0,1,SAVED                                                84000000
         STM   6,7,SAVED                                                84250000
         ICALL STORE                                                    84500000
         QUEND                                                          84750000
         BCT   8,MOVELP                                                 85000000
         LR    0,6                 DEPOSIT LAST ITEM                    85250000
         LR    1,7                      BACK WHERE FIRST ONE WAS.       85500000
         LDR   0,2                                                      85750000
         L     2,CLOSS                                                  86000000
         LR    10,2                TOP OF LOOP NEEDS IT                 86250000
         AR    2,5                                                      86500000
         ICALL STORE                                                    86750000
         B     CLASSLP                                                  87000000
ROTEND   L     LKR,ROORET                                               87250000
         BR    LKR                                                      87500000
         LTORG                                                          87750000
SHFCT    DC    FL1'2,3,0'                                               88000000
         TITLE 'R E V E R S E'                                          88250000
EXMREV   CSECT                                                          88500000
         USING *,9                                                      88750000
         ST    LKR,ROORET                                               89000000
         L     8,=A(SCNSETUP)                                           89250000
         BALR  LKR,8                                                    89500000
         CLI   TRIV+3,0                                                 89750000
         BE    REVEND                                                   90000000
         L     10,LOPROD           R10  PROD/LOW DIMENSIONS             90250000
NEXT     L     8,=A(NEXTVECT)                                           90500000
         BALR  LKR,8                                                    90750000
         BE    REVEND                                                   91000000
         LM    3,4,RCFTYPE                                              91250000
         L     5,ORX               R5  RX                               91500000
         L     6,DIF                                                    91750000
         AR    6,5                 R6  RHX                              92000000
XCH      CR    5,6                                                      92250000
         BNL   NEXT                                                     92500000
         LR    2,5                                                      92750000
         ICALL FETCH                                                    93000000
         LR    7,0                                                      93250000
         LR    8,1                 R7, R8  TEMP                         93500000
         LDR   2,0                                                      93750000
         LR    2,6                                                      94000000
         ICALL FETCH                                                    94250000
         LR    2,5                                                      94500000
         ICALL STORE                                                    94750000
         LR    0,7                                                      95000000
         LR    1,8                                                      95250000
         LDR   0,2                                                      95500000
         LR    2,6                                                      95750000
         ICALL STORE                                                    96000000
         AR    5,10                                                     96250000
         SR    6,10                                                     96500000
         QUEND                                                          96750000
         B     XCH                                                      97000000
REVEND   L     LKR,ROORET                                               97250000
         BR    LKR                                                      97500000
         LTORG                                                          97750000
         END                                                            98000000
./  ADD    NAME=APLSSCOP
SCOP     TITLE 'SCALAR EXECUTION ROUTINES                     05/11/70' 00150000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00300000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00450000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00600000
SCOPS    CSECT                                                          00750000
         PRINT OFF       APLDEFN                                        01050000
         COPY  APLDEFN                                                  01200000
         PRINT ON,NOGEN                                                 01350000
         COPY  OPSECT                                                   01500000
         TITLE 'SCALAR EXECUTION ROUTINES                     05/11/70' 01650000
         EXTRN ERROR                                                    01800000
SCOPS    CSECT                                                          01950000
*                                                                       02100000
*        SCALAR OPERATOR EXECUTION ROUTINES.                            02250000
*                                                                       02400000
         USING OPSECT-16,LR                                             02550000
*                                                                       02700000
*        ADD, SUBTRACT, MULTIPLY, DIVIDE.                               02850000
*                                                                       03000000
EXADD    EQU   *                   INTEGER ADD.                         03150000
         ENTRY EXADD                                                    03300000
         AR    1,2                                                      03450000
         BR    LKR                                                      03600000
*                                                                       03750000
EXFAD    EQU   *                   FLOATING ADD                         03900000
         ENTRY EXFAD                                                    04050000
         ADR   0,2                                                      04200000
         BR    LKR                                                      04350000
*                                                                       04500000
EXSUB    EQU   *                   INTEGER SUBTRACT                     04650000
         ENTRY EXSUB                                                    04800000
         SR    1,2                                                      04950000
         BR    LKR                                                      05100000
*                                                                       05250000
EXFSB    EQU   *                   FLOATING SUBTRACT.                   05400000
         ENTRY EXFSB                                                    05550000
         SDR   0,2                                                      05700000
         BR    LKR                                                      05850000
*                                                                       06000000
EXMPY    EQU   *                   INTEGER MULTIPLY.                    06150000
         ENTRY EXMPY                                                    06300000
         MR    0,2                                                      06450000
         SLDA  0,32                OVERFLOW TEST ********************** 06600000
         LR    1,0                                                      06750000
         BR    LKR                                                      06900000
*                                                                       07050000
EXFMP    EQU   *                   FLOATING MULTIPLY.                   07200000
         ENTRY EXFMP                                                    07350000
         MDR   0,2                                                      07500000
         BR    LKR                                                      07650000
*                                                                       07800000
EXFDP    EQU   *                   DIVIDE.                              07950000
         ENTRY EXFDP                                                    08100000
         DDR   0,2                                                      08250000
         BR    LKR                                                      08400000
*                                                                       08550000
         EJECT                                                          08700000
*                                                                       08850000
*        MAX, MIN.                                                      09000000
*                                                                       09150000
EXMAX    EQU   *                   INTEGER MAXIMUM.                     09300000
         ENTRY EXMAX                                                    09450000
         CR    1,2                                                      09600000
         BCR   10,LKR                                                   09750000
         LR    1,2                                                      09900000
         BR    LKR                                                      10050000
*                                                                       10200000
EXDMAX   EQU   *                   FLOATING MAXIMUM.                    10350000
         ENTRY EXDMAX                                                   10500000
         CDR   0,2                                                      10650000
         BCR   10,LKR                                                   10800000
         LDR   0,2                                                      10950000
         BR    LKR                                                      11100000
*                                                                       11250000
EXMIN    EQU   *                   INTEGER MINIMUM.                     11400000
         ENTRY EXMIN                                                    11550000
         CR    1,2                                                      11700000
         BCR   12,LKR                                                   11850000
         LR    1,2                                                      12000000
         BR LKR                                                         12150000
*                                                                       12300000
EXDMIN   EQU   *                   FLOATING MINIMUM.                    12450000
         ENTRY EXDMIN                                                   12600000
         CDR   0,2                                                      12750000
         BCR   12,LKR                                                   12900000
         LDR   0,2                                                      13050000
         BR    LKR                                                      13200000
         EJECT                                                          13350000
*                                                                       13500000
*        RESIDUE                                                        13650000
*                                                                       13800000
EXRES    EQU   *                                                        13950000
         ENTRY EXRES                                                    14100000
         USING EXRES,9                                                  14250000
         LPER  0,0                 TAKE ABSOLUTE A                      14400000
         BZ    RES3                0 RES B IS B (IF B POSITIVE)         14550000
         STD   0,A                                                      14700000
         STE   2,BSIGN             SAVE TRUE SIGN OF B FOR POSSIBLE     14850000
RES4     XI    BSIGN,X'80'                                              15000000
         LPER  2,2                 DECOMPLEMENTATION AT RES2            15150000
RES1     CDR   0,2                 END TEST IS A GTR REDUCED B          15300000
         BH    RES2                                                     15450000
         STD   2,B                                                      15600000
         DDR   2,0                 THE FOLLOWING TAKES A SIX-OR-LESS-   15750000
         LD    4,DMKFLOOR          DIGIT QUOTIENT B/A, MULTIPLIES       15900000
*                                  (ACCURATELY) BY A, AND SUBTRACTS     16050000
*                                  THIS (ALSO ACCURATELY) FROM B.       16200000
         LDR   6,4                 USED TO SPLIT F0                     16350000
         ADR   2,4                 LOSE FRACTIONAL PART OF B/A, IF ANY  16500000
         LER   4,2                 HIGH 6 DIGITS OF FLOOR B/A           16650000
         LER   6,0                 HIGH 6 DIGITS OF A                   16800000
         SDR   0,6                 LOW 8 DIGITS OF A                    16950000
         MER   6,4                 HIGH 12 DIGITS OF A * FLOOR B/A      17100000
         MDR   0,4                 LOW 14 DIGITS OF  A * FLOOR B/A      17250000
*                                  (OVERLAPPING BY 8 DIGITS)            17400000
         LD    2,B                 14 DIGITS OF B                       17550000
         SDR   2,6                 CANCEL 5 OR 6 DIGITS OF B            17700000
         SDR   2,0                 R2 HOLDS TRUE B - A * FLOOR B/A      17850000
         LD    0,A                 RECALL MODULUS                       18000000
         BNM   RES1                AND ITERATE IF NOT ENOUGH SIGNIFI-   18150000
*                                  CANCE HAS BEEN REMOVED FROM B.       18300000
*                                  POSSIBILITY EXISTS ON MOD 91 OF F2   18450000
         B     RES4                GOING NEGATIVE.  EXAMPLE IN 4-DIGIT  18600000
*                                  DECIMAL IS  3 RES 5999 .  SINCE F2   18750000
*                                  IS CONGRUENT MOD A TO THE CORRECT    18900000
*                                  RESULT WE RECYCLE AS IF IT WERE THE  19050000
*                                  ORIGINAL ARGUMENT (EXCEPT FOR DECOM- 19200000
*                                  PLEMENTATION)                        19350000
*                                  SIGNIFICANCE HAS BEEN REMOVED FROM B 19500000
RES2     CLI   BSIGN,X'80'         RESIDUE MAY NEED DECOMPLEMENTATION   19650000
         BNL   RES3                NO, B WAS POSITIVE                   19800000
         LTER  2,2                 YES, B WAS NEGATIVE.                 19950000
         BZ    RES3                QUIT NOW IF A RES -B IS 0            20100000
         SDR   0,2                                                      20250000
         BR    LKR                 F0 IS ACCURATE A - A RES -B          20400000
RES3     LTDR  0,2                 PUT RESIDUE IN F0                    20550000
         BCR   11,LKR              RETURN UNLESS A = 0 AND B LESS 0     20700000
         B     RNGEROR                                                  20850000
         DROP  9                                                        21000000
         EJECT                                                          21150000
*                                                                       21300000
*        INTEGER RESIDUE.                                               21450000
*                                                                       21600000
EXFRES   EQU   *                                                        21750000
         ENTRY EXFRES                                                   21900000
         USING EXFRES,9                                                 22050000
         LR    0,2                 SET UP FOR DR 0,2                    22200000
         LPR   2,1                 ABSOLUTE A                           22350000
         BZ    FRES0               QUICK EXIT FOR 0 RESIDUE             22500000
         SRDA  0,32                EXTEND SIGN OF B                     22650000
         DR    0,2                                                      22800000
         LTR   1,0                 REMAINDER TO R1                      22950000
         BCR   11,LKR              EXIT IF NON-NEGATIVE                 23100000
         AR    1,2                 OTHERWISE DECOMPLEMENT               23250000
         BR    LKR                                                      23400000
FRES0    LTR   1,0                 0 RESIDUE REQUIRES NON-NEGATIVE B    23550000
         BCR   11,LKR                                                   23700000
         B     RNGEROR                                                  23850000
         DROP  9                                                        24000000
         EJECT                                                          24150000
*                                                                       24300000
*        RELATIONAL OPERATORS.                                          24450000
*        RESULT RETURNED IN R1.                                         24600000
*        -     = TRUE.                                                  24750000
*        + = FALSE.                                                     24900000
*                                                                       25050000
EXLSTH   EQU   *                   INTEGER LESS THAN.                   25200000
         ENTRY EXLSTH                                                   25350000
         CR    1,2                                                      25500000
         LA    1,0                                                      25650000
         BCR   11,LKR                                                   25800000
         BCTR  1,LKR                                                    25950000
*                                                                       26100000
EXDLSTH  EQU   *                   FLOATING LESS THAN.                  26250000
         ENTRY EXDLSTH                                                  26400000
         SR    1,1                 INITIALIZE RESULT                    26550000
         SWR   0,2                                                      26700000
         BCR   2,LKR                                                    26850000
         STD   0,DTEMP                                                  27000000
         CLC   DTEMP+1(7),FUZZ+1                                        27150000
         BCR   13,LKR                                                   27300000
         BCTR  1,LKR                                                    27450000
*                                                                       27600000
EXLSTHEQ EQU   *                   INTEGER LESS THAN OR EQUAL.          27750000
         ENTRY EXLSTHEQ                                                 27900000
         CR    1,2                                                      28050000
         LA    1,0                                                      28200000
         BCR   3,LKR                                                    28350000
         BCTR  1,LKR                                                    28500000
*                                                                       28650000
EXDLSTHE EQU   *                   FLOATING LESSTHAN OR EQUAL.          28800000
         ENTRY EXDLSTHE                                                 28950000
         USING EXDLSTHE,9                                               29100000
         SR    1,1                  INITIALIZE RESULT FALSE.            29250000
         SWR   0,2                                                      29400000
         BNP   TDLSTH                                                   29550000
         STD   0,DTEMP                                                  29700000
         CLC   DTEMP+1(7),FUZZ+1                                        29850000
         BCR   2,LKR                                                    30000000
TDLSTH   BCTR  1,LKR                                                    30150000
         DROP  9                                                        30300000
*                                                                       30450000
EXEQUAL  EQU   *                   INTEGER EQUAL.                       30600000
         ENTRY EXEQUAL                                                  30750000
         CR    1,2                                                      30900000
         LA    1,0                                                      31050000
         BCR   7,LKR                                                    31200000
         BCTR  1,LKR                                                    31350000
*                                                                       31500000
EXDEQUAL EQU   *                   FLOATING EQUAL.                      31650000
         ENTRY EXDEQUAL                                                 31800000
         SR    1,1                 SET RESULT FALSE.                    31950000
         SWR   0,2                                                      32100000
         STD   0,DTEMP                                                  32250000
         CLC   DTEMP+1(7),FUZZ+1                                        32400000
         BCR   2,LKR                                                    32550000
         BCTR  1,LKR                                                    32700000
*                                                                       32850000
EXNOTEQU EQU   *                   INTEGER NOT EQUAL.                   33000000
         ENTRY EXNOTEQU                                                 33150000
         CR    1,2                                                      33300000
         LA    1,0                                                      33450000
         BCR   8,LKR                                                    33600000
         BCTR  1,LKR                                                    33750000
*                                                                       33900000
EXDNOTEQ EQU   *                   FLOATING NOT EQUAL.                  34050000
         ENTRY EXDNOTEQ                                                 34200000
         LA    1,0                                                      34350000
         SWR   0,2                                                      34500000
         STD   0,DTEMP                                                  34650000
         CLC   DTEMP+1(7),FUZZ+1                                        34800000
         BCR   13,LKR                                                   34950000
         BCTR  1,LKR                                                    35100000
*                                                                       35250000
EXGRTHEQ EQU   *                   INTEGER GREATER THAN OR EQUAL.       35400000
         ENTRY EXGRTHEQ                                                 35550000
         CR    1,2                                                      35700000
         LA    1,0                                                      35850000
         BCR   5,LKR                                                    36000000
         BCTR  1,LKR                                                    36150000
*                                                                       36300000
EXDGRTHE EQU   *                   FLOATING GREATER THAN OR EQUAL.      36450000
         ENTRY EXDGRTHE                                                 36600000
         USING EXDGRTHE,9                                               36750000
         SR    1,1                                                      36900000
         SWR   0,2                                                      37050000
         BNM   TDGE                                                     37200000
         STD   0,DTEMP                                                  37350000
         CLC   DTEMP+1(7),FUZZ+1                                        37500000
         BCR   2,LKR                                                    37650000
TDGE     BCTR  1,LKR                                                    37800000
         DROP  9                                                        37950000
*                                                                       38100000
EXGRTH   EQU   *                   INTEGER GREATER THAN.                38250000
         ENTRY EXGRTH                                                   38400000
         CR    1,2                                                      38550000
         LA    1,0                                                      38700000
         BCR   13,LKR                                                   38850000
         BCTR  1,LKR                                                    39000000
*                                                                       39150000
EXDGRTH  EQU   *                   FLOATING GREATER THAN.               39300000
         ENTRY EXDGRTH                                                  39450000
         SR    1,1                                                      39600000
         SWR   0,2                                                      39750000
         BCR   4,LKR                                                    39900000
         STD   0,DTEMP                                                  40050000
         CLC   DTEMP+1(7),FUZZ+1                                        40200000
         BCR   13,LKR                                                   40350000
         BCTR  1,LKR                                                    40500000
         EJECT                                                          40650000
*                                                                       40800000
*        MONADIC SCALAR OPS.                                            40950000
*        ARG IN HIGH REGISTER, RESULT IN LOW.                           41100000
*                                                                       41250000
*                 FLOATING FLOOR AND CEILING                            41400000
*                                                                       41550000
*              FLOOR AND CEILING ARE FUZZED AS FOLLOW,                  41700000
*              RESULT IS ZERO IF CPUTFUZZ GE ABS ARG.                   41850000
*              FOR FLOOR, THE RESULT IS THE TRUE FLOOR UNLESS           42000000
*              THE ARG IS GREATER THAN THE TRUE FLOOR AND EQUAL TO      42150000
*              THE TRUE CEILING (WHERE BOTH COMPARISONS ARE FUZZED).    42300000
*              FOR CEILING, THE RESULT IS THE TRUE CEILING UNLESS       42450000
*              THE ARG IS LT THE TRUE CEILING AND EQUAL TO THE          42600000
*              TRUE FLOOR (WHERE BOTH COMPARISONS ARE FUZZED).          42750000
*                                                                       42900000
         SPACE                                                          43050000
EXDCEIL  EQU   *                   FLOATING CEILING.                    43200000
         ENTRY EXDCEIL                                                  43350000
         USING EXDCEIL,9                                                43500000
         LA    1,1                 SET CEILING FLAG                     43650000
         BAL   2,INIT              GO TO COMMON ROUTINE WITH FLOOR      43800000
*              * * * * * * * USING FOR FLOOR MUST FOLLOW IMMEDIATELY *  43950000
         DROP  9                                                        44100000
*                                                                       44250000
EXDFLOOR EQU   *                   FLOATING FLOOR.                      44400000
         ENTRY EXDFLOOR                                                 44550000
         USING EXDFLOOR,2                                               44700000
         LR    2,9                                                      44850000
         SR    1,1                 SET FLOOR FLAG                       45000000
INIT     LPDR  0,2                 WANT EXPONENT BYTE WITH + SIGN       45150000
         STE   0,DTEMP                                                  45300000
         CD    0,DBLHALF                                                45450000
         BH    RELF                IF ABS ARG GT .5 THEN USE REL FUZZ   45600000
         MVI   DTEMP,X'40'         SET EXP BYTE FOR ABS FUZZ            45750000
         CLC   CPUTFUZZ+1(7),DUNZERO+1                                  45900000
         BNE   RELF                IF FUZZ NONZERO MERGE  WITH REL F    46050000
         LDR   0,2                 SPECIAL CASE OF ZERO FUZZ AND        46200000
         SDR   2,2                 ARG IS SMALL                         46350000
         BXH   1,1,CLNRZ                                                46500000
         LTER  0,0                                                      46650000
         BNM   TRUNCATE                                                 46800000
         SD    2,DBLONE                                                 46950000
         B     TRUNCATE                                                 47100000
CLNRZ    LTER  0,0                                                      47250000
         BNP   TRUNCATE                                                 47400000
         LD    2,DBLONE                                                 47550000
         B     TRUNCATE                                                 47700000
RELF     MVC   DTEMP+1(7),CPUTFUZZ+1 MOVE FUZZ BITS INTO PLACE          47850000
         LD    4,DTEMP             F4 CONTAINS RELATIVE FUZZ            48000000
         CD    4,DBLHALF                                                48150000
         BL    *+6                                                      48300000
         SDR   4,4                 SET FUZZ TO ZERO                     48450000
CASE     BXH   1,1,SETUPCL         GO BACK TO DOING CEILING             48600000
         ADR   2,4                 INCREASE ARG BY FUZZ                 48750000
         BP    TRUNCATE            JUST TRUNCATE IF POSITIVE ARG        48900000
         SD    2,DBLONEM           DECREASE BY ALMOST 1                 49050000
TRUNCATE AW    2,DUNZERO           TRUNCATE TO INTEGER                  49200000
         CLI   BLOWN,0             RETURN NOW IF FLOATING RESULT        49350000
         BNE   CEFL2               REQUESTED                            49500000
         STD   2,DBLHOLD                                                49650000
         L     1,DBLHOLD+4         ELSE TRANSFER TO FIXED REG           49800000
         AWR   2,2                 TEST SIGN, SET UP FOR MAGNITUDE TEST 49950000
         BNM   *+6                                                      50100000
         LCR   1,1                                                      50250000
         LTER  2,2                 NONZERO IF F2 WAS GEQ 2*31           50400000
         BCR   8,LKR                                                    50550000
         L     1,=V(BLOWUP)                                             50700000
         BR    1                                                        50850000
SETUPCL  SDR   2,4                 DECREASE ARG BY FUZZ                 51000000
         BM    TRUNCATE            JUST TRUNCATE IF NEG ARG             51150000
         AD    2,DBLONEM           INCREASE BY ALMOST 1                 51300000
         B     TRUNCATE            NOW TRUNCATE                         51450000
         DROP  2                                                        51600000
*                                                                       51750000
EXMADD   EQU   *                   MONADIC ADD                          51900000
         ENTRY EXMADD                                                   52050000
         LR    1,2                                                      52200000
         BR    LKR                                                      52350000
*                                                                       52500000
EXMCIRC  EQU   *                   DIAMETER FUNCTION                    52650000
         ENTRY EXMCIRC                                                  52800000
         USING EXMCIRC,9                                                52950000
         DD    2,IPI               IS PI TIMES ARG                      53100000
*        DIVIDE IS ANCIENT NON-GUARD-DIGIT HISTORY BUT HELPS MOD 91 TOO 53250000
         DROP  9                                                        53400000
*                                                                       53550000
EXMFAD   EQU   *                                                        53700000
CEFL2    EQU   EXMFAD                                                   53850000
         ENTRY EXMFAD                                                   54000000
         SDR   0,0                                                      54150000
         ADR   0,2                 NORMALIZE JUST IN CASE               54300000
         BR    LKR                                                      54450000
*                                                                       54600000
EXMSUBT  EQU   *                                                        54750000
         ENTRY EXMSUBT                                                  54900000
         LCR   1,2                                                      55050000
         BR    LKR                                                      55200000
*                                                                       55350000
EXMFSB   EQU   *                                                        55500000
         ENTRY EXMFSB                                                   55650000
         LCDR  0,2                                                      55800000
         BCR   7,LKR                                                    55950000
         LPER  0,0                                                      56100000
         BR    LKR                                                      56250000
*                                                                       56400000
         ENTRY EXMMPY                                                   56550000
EXMMPY   EQU   *                   SIGN -- (X GTR 0) - (X LSS 0)        56700000
         LTR   1,2                                                      56850000
         BCR   8,LKR                                                    57000000
         LA    1,1                                                      57150000
         BCR   2,LKR                                                    57300000
         LCR   1,1                                                      57450000
         BR    LKR                                                      57600000
*                                                                       57750000
EXMFMP   EQU   *                   SIGN FUNCTION, FLOATING ARG          57900000
         ENTRY EXMFMP                                                   58050000
         USING *,9                                                      58200000
         LTDR  0,2                                                      58350000
         BCR   8,LKR                                                    58500000
         LD    0,DBLONE                                                 58650000
         BCR   2,LKR                                                    58800000
         LCER  0,0                                                      58950000
         BR    LKR                                                      59100000
         DROP  9                                                        59250000
*                                                                       59400000
EXABS    EQU   *                   INTEGER ABSOLUTE VALUE.              59550000
         ENTRY EXABS                                                    59700000
         LPR   1,2                                                      59850000
         BR    LKR                                                      60000000
*                                                                       60150000
EXDABS   EQU   *                   FLOATING ABSOLUTE VALUE.             60300000
         ENTRY EXDABS                                                   60450000
         LPDR  0,2                                                      60600000
         BR    LKR                                                      60750000
*                                                                       60900000
EXCEIL   EQU   EXMADD              INTEGER CEILING                      61050000
         ENTRY EXCEIL                                                   61200000
*                                                                       61350000
EXFLOOR  EQU   EXMADD              INTEGER FLOOR                        61500000
         ENTRY EXFLOOR                                                  61650000
         EJECT                                                          61800000
*                                                                       61950000
FRANDOM  EQU   *                   INTEGER MONADIC QUERY                62100000
         ENTRY FRANDOM                                                  62250000
         USING *,9                                                      62400000
*        WE ARE TAKING ADVANTAGE IN THESE ROUTINES OF THE FACT THAT THE 62550000
*        NUMBER GENERATED BY  RANDOM  IS BETWEEN 0 AND 2*31-1 AND THAT  62700000
*        WE MAY CONSIDER THIS A FRACTION UNIFORMLY DISTRIBUTED BETWEEN  62850000
*        0 AND 1.                                                       63000000
         ST    LKR,RSAVE                                                63150000
         LTR   2,2                 SEE IF OPERAND IS POSITIVE           63300000
         BNH   RNGERR              DOMAIN ERROR IF NOT                  63450000
         LA    10,RANDOM           BASE REGISTER FOR RANDOM.            63600000
         BALR  LKR,10              GET A RANDOM NUMBER.                 63750000
         MR    0,2                 MULTIPLY BY ARG                      63900000
         SLDL  0,1                                                      64050000
         A     0,IORIGIN           ADD IN INDEX ORIGIN                  64200000
         LR    1,0                 R1 IS RESULT REGISTER                64350000
         L     LKR,RSAVE                                                64500000
         BR    LKR                                                      64650000
         DROP  9                                                        64800000
*                                                                       64950000
DRANDOM  EQU   *                   FLOATING MONADIC QUERY               65100000
         ENTRY DRANDOM                                                  65250000
         USING *,9                                                      65400000
         ST    LKR,RSAVE                                                65550000
         LTDR  0,2                 OPERAND MUST BE POSITIVE INTEGER.    65700000
         BNP   RNGERR              ERROR IF NOT.                        65850000
*              CHECK FOR FRACTIONAL PART LESS THAN FUZZ WITHOUT         66000000
*              REQUIRING MAGNITUDE TO BE LSS 2*31                       66150000
         AD    2,DMKFLOOR          INTEGERIZE                           66300000
         SWR   2,0                 SUBTRACT OPERAND.                    66450000
         STD   2,DSAVE             SAVE RESULT OF SUBTRACTION.          66600000
         CLC   DSAVE+1(7),CNVTFUZZ+1                                    66750000
         BH    RNGERR              REALLY HAS A FRACTIONAL PART         66900000
         CD    0,=D'2147483647'    TO DRAND3 IF ARG LTEQ 2*31-1    3592 67050000
         BNH   DRAND3                                              3592 67200000
         LA    10,RANDOM           BASE RESISTER FOR RANDOM.            67350000
         BALR  LKR,10              GET A RANDOM NUMBER.                 67500000
         LR    2,1                 SAVE IT IN R2                        67650000
         BALR  LKR,10              GET A RANDOM NUMBER.                 67800000
         LR    0,2                 RECALL FIRST RANDOM                  67950000
         ALR   1,1                 DO A COUPLE OF SHIFTS TO FORM 62-BIT 68100000
         SLDL  0,1                 RANDOM INTEGER                       68250000
         ST    1,DSAVE+4           GET RANDOMS INTO FLOATING REGISTERS  68400000
         LD    4,DSAVE                                                  68550000
         ST    0,DSAVE+4                                                68700000
         LD    2,DSAVE                                                  68850000
         LE    2,QU40HEX           PUT IN SIGNS AND EXPONENTS.          69000000
         LE    4,QU38HEX                                                69150000
         MDR   4,0                 MULTIPLY MIDDLE PIECE BY OPERAND.    69300000
         CLI   DSAVE+4,2           SEE IF THERE WERE 6 OR MORE L ZEROS. 69450000
         BNL   DRAND2              BRANCH IF NOT - WON'T LOSE SIGNIFANC 69600000
         BALR  LKR,10              OTHERWISE, GET ANOTHER RANDOM NO.    69750000
         ALR   1,1                                                      69900000
         ST    1,DSAVE+4                                                70050000
         LD    6,DSAVE             GET IT INTO F6.                      70200000
         LE    6,QU30HEX           WITH AN EXPONENT.                    70350000
         MDR   6,0                 MULTIPLY BY OPERAND.                 70500000
         ADR   4,6                 ADD INTO RESULT SO FAR.              70650000
DRAND2   MDR   0,2                 MULTIPLY HIGH ORDER BITS BY OPERAND. 70800000
         ADR   0,4                 ADD IN REST - NOW HAVE 56 RANDOM BTS 70950000
         MVC   DSAVE+4(4),IORIGIN                                       71100000
         LD    2,DSAVE                                                  71250000
         LE    2,DUNZERO                                                71400000
         ADR   0,2                 ADD IORIGIN AND INTEGERIZE.          71550000
         AD    0,DMKFLOOR                                               71700000
         L     LKR,RSAVE                                                71850000
         BR    LKR                                                      72000000
         SPACE 2                                                   3592 72150000
*        FLOATING ARGUMENT IS 2*31-1 OR LESS.  CONVERT FLOATING    3592 72300000
*        ARG TO FIXED POINT AND USE FRANDOM. THIS AVOIDS           3592 72450000
*        INCONSISTENT RESULTS WHICH DEPEND ON WHETHER ARGUMENT     3592 72600000
*        IS INTERNALLY STORED AS FIXED OR FLOATING.                3592 72750000
DRAND3   AW    0,DUNZERO           THIS SHUFFLE CONVERTS FLOATING  3592 72900000
         STD   0,DSAVE              ARG TO FIXED POINT IN          3592 73050000
         L     2,DSAVE+4           GENERAL REG 2.                  3592 73200000
         ST    LKR,RSAVE+4         FRANDOM USES RSAVE              3592 73350000
         L     9,=A(FRANDOM)       SET FRANDOM BASE REG            3592 73500000
         BALR  LKR,9               OFF TO FRANDOM, RESULT IN GR1   3592 73650000
         BALR  9,0                 REESTABLISH ADDRESSABILITY      3592 73800000
         USING *,9                                                 3592 73950000
         ST    1,DSAVE+4           THIS SHUFFLE CONVERTS           3592 74100000
         LD    0,DSAVE              POS FRANDOM RESULT FROM        3592 74250000
         LE    0,DUNZERO            INTEGER TO NORMALIZED          3592 74400000
         SD    0,DUNZERO            FLOATING POINT.                3592 74550000
         L     9,=A(DRANDOM)       RESET DRANDOM BASE REG.         3592 74700000
         L     LKR,RSAVE+4         RECALL DRANDOM'S RETURN REG.    3592 74850000
         BR    LKR                                                 3592 75000000
         SPACE 2                                                   3592 75150000
         DROP  9                                                        75300000
*                                                                       75450000
*        RANDOM NUMBER GENERATOR.                                       75600000
*                                                                       75750000
*        LEHMER'S METHOD, CACM JUNE '66, P 432.                         75900000
*                                                                       76050000
*        N(I+1) = P RES Q X N(I)                                        76200000
*        P = (2**31)-1                                                  76350000
*        Q = 7**5                                                       76500000
*                                                                       76650000
         ENTRY RANDOM                                                   76800000
RANDOM   EQU   *                                                        76950000
         USING *,10                                                     77100000
         L     1,RNUMBER           PICK UP LAST RANDOM NO.              77250000
         LTR   1,1                 SEE IF IT'S ZERO.                    77400000
         BP    *+8                 BRANCH IF POSITIVE.                  77550000
         L     1,QU7T5             OTHERWISE, PICK UP STARTER.          77700000
         M     0,QU7T5             X 7**5                               77850000
         D     0,QU2T31            DIV (2**31)-1                        78000000
         ST    0,RNUMBER           STORE RESULT.                        78150000
         LR    1,0                                                      78300000
         BR    LKR                                                      78450000
         DROP  10                                                       78600000
         EJECT                                                          78750000
*                                                                       78900000
*        LOGICAL OPERATORS.                                             79050000
*                                                                       79200000
EXNOT    EQU   *                   NOT.                                 79350000
         ENTRY EXNOT                                                    79500000
         USING EXNOT,9                                                  79650000
         X     2,ALLONE                                                 79800000
         LR    1,2                                                      79950000
         BR    LKR                                                      80100000
         DROP  9                                                        80250000
*                                                                       80400000
EXAND    EQU   *                   AND.                                 80550000
         ENTRY EXAND                                                    80700000
         NR    1,2                                                      80850000
         BR    LKR                                                      81000000
*                                                                       81150000
EXOR     EQU   *                   OR.                                  81300000
         ENTRY EXOR                                                     81450000
         OR    1,2                                                      81600000
         BR    LKR                                                      81750000
*                                                                       81900000
EXNAND   EQU   *                  NAND                                  82050000
         ENTRY EXNAND                                                   82200000
         USING EXNAND,9                                                 82350000
         NR    1,2                                                      82500000
         X     1,ALLONE                                                 82650000
         BR    LKR                                                      82800000
         DROP  9                                                        82950000
*                                                                       83100000
EXNOR    EQU   *                  NOR                                   83250000
         ENTRY EXNOR                                                    83400000
         USING EXNOR,9                                                  83550000
         OR    1,2                                                      83700000
         X     1,ALLONE                                                 83850000
         BR    LKR                                                      84000000
         DROP  9                                                        84150000
         EJECT                                                          84300000
*                                                                       84450000
*    RECIPROCAL  (MONADIC DIVIDE)                                       84600000
*                                                                       84750000
         SPACE                                                          84900000
EXMFDP   EQU   *                                                        85050000
         ENTRY EXMFDP                                                   85200000
         USING *,9                                                      85350000
         LD    0,DBLONE                                                 85500000
         DDR   0,2                                                      85650000
         BR    LKR                                                      85800000
         DROP  9                                                        85950000
         EJECT                                                          86100000
*                                                                       86250000
*        ARTHTP ERROR ROUTINE.                                          86400000
*                                                                       86550000
*        THIS ROUTINE IS ENTERED IF AN INVALID OPERATION IS REQUESTED.  86700000
*        FOR EXAMPLE, IF AN OPERATOR WHICH MAY BE DYADIC ONLY           86850000
*        IS PRESENTED TO ARTHTP WITH ONLY ONE OPERAND, THE ADDRESS      87000000
*        OF THIS ROUTINE IS RETURNED AS THE OPERATOR EXECUTION ROUTINE. 87150000
*        IF THE ERROR GOES UNDETECTED UNTIL EXECUTION TIME, THEN THE    87300000
*        EXECUTE WILL CAUSE A TRANSFER HERE, AND EXECUTION WILL BE      87450000
*        ABANDONED.                                                     87600000
*                                                                       87750000
*        NOTE...                                                        87900000
*        ****                                                           88050000
*                                                                       88200000
*        AN ERROR IN ARTHTP MAY RESULT IN THIS ERROR BEING GENERATED.   88350000
*                                                                       88500000
EXERROR  EQU   *                                                        88650000
         ENTRY EXERROR                                                  88800000
         BALR  9,0                                                      88950000
         USING *,9                                                      89100000
         LA    1,ESYNTAX                                                89250000
         ICALL ERROR                                                    89400000
         DROP  9                                                        89550000
         EJECT                                                          89700000
*                                                                       89850000
*        WE END UP HERE WITH A RANGE ERROR.                             90000000
*                                                                       90150000
RNGERR   EQU   *                                                        90300000
RNGEROR  EQU   RNGERR                                                   90450000
         BALR   9,0                                                     90600000
         USING *,9                 SO WE NEED TO SET A BASE REGISTER.   90750000
         LA    1,ERANGE                                                 90900000
         ICALL ERROR                                                    91050000
         DROP  9                                                        91200000
         TITLE 'CONSTANTS.'                                             91350000
FUZZ     EQU   RFUZZ                                                    91500000
CPUTFUZZ EQU   RFUZZ                                                    91650000
DBLONE   DC    D'1'                                                     91800000
DBLHALF  DC    D'.5'                                                    91950000
CNVTFUZZ DC    X'40000000000003FF'                                      92100000
DUNZERO  DC    X'4E00000000000000'                                      92250000
DMKFLOOR DC    X'4F00000000000000'                                      92400000
DBLONEM  DC    X'40FFFFFFFFFFFFFF'                                      92550000
ALLONE   EQU   *-4                                                      92700000
IPI      DC    D'.31830988618379067153'  INVERSE PI                     92850000
F1       DC    F'1'                                                     93000000
QU30HEX  DC    X'36000000'                                              93150000
QU38HEX  DC    X'3E000000'                                              93300000
QU40HEX  DC    X'46000000'                                              93450000
QU7T5    DC    F'16807'            7**5                                 93600000
QU2T31   DC    X'7FFFFFFF'         (2**31)-1                            93750000
         LTORG                                                          93900000
         END                                                            94050000
./  ADD    NAME=APLSSINI
SINI     TITLE 'APLSUP LOAD AND INITIALIZE ROUTINE            05/11/70' 00080000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00160000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00240000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00320000
         MACRO                                                          00400000
&L       COMRG                                                          00480000
         MNOTE 7,'ENVIRONMENT CONFUSION.'                               01040000
         MEND                                                           01120000
         GBLA  &SLOP                                                    01280000
TYBUFG   CSECT                                                          01440000
&SLOP    SETA  2048                                                     01520000
         PRINT OFF                 COPY PERTERM  DIRSECT                01680000
         COPY  PERTERM             TO GET PERBUF                        01760000
         COPY  DIRSECT                                                  01840000
         PRINT ON                                                       01920000
EMPTYM   EQU   X'80'                                                    02000000
TYBUFG   CSECT                                                          02080000
*        TYBUFG CONTAINS INITIALIZATION CODE WHICH IS THEN OVERLAID BY  02160000
*        TYPEWRITER BUFFERS AT THE END OF INITIALIZATION.  ALL OTHER    02240000
*        INITIALIZATION CODE IS CLOBBERED BY BUFFERS AT THIS TIME SO    02320000
*        THIS MUST BE THE LAST INITIALIZATION FUNCTION.                 02400000
*        ORDER OF STORAGE AT LINK TIME IS ASSUMED TO BE..               02480000
*                                                                       02560000
*        LOW ADDR OF PARTITION                                          02640000
*        APLSUP, TABLES, INTERPRETER, ETC.                              02720000
*        TYBUFG CSECT                                                   02800000
*        OTHER INITIALIZATION SUBROUTINES                               02880000
*        UNUSED                                                         02960000
*        HIGH ADDRESS OF PARTITION                                      03040000
*                                                                       03120000
*        AFTER SUPINI FINISHES AND DOES QUANTUM END..                   03200000
*                                                                       03280000
*        APLSUP, TABLES, INTERPRETER, ETC.                              03360000
*        TYBUFG CSECT                                                   03440000
*        TYPEWRITER BUFFERS                                             03520000
*        WORKSPACES                                                     03600000
*        HIGH ADDRESS OF PARTITION                                      03680000
*                                                                       03760000
*        FOLLOWING CODE ASSUMES L'PBSTAR IS AT LEAST TWELVE AND THAT    03840000
*        ITB1 DOES NOT TOUCH FIRST WORD OF PBCCW.  NOTE THAT IT LIVES   03920000
*        IN PBSTAR AND POSSIBLY HALF OF PBCCW.  IT IS EXECUTED IN       04000000
*        SUPVR STATE WITH INTERRUPTS DISABLED.  SVINIT IN APLSUP IS     04080000
*        CALLER.                                                        04160000
TB1      DC    D'0'                FIRST PBCCW                          04240000
         DC    F'0'                FIRST PBTIC                          04320000
*                                                                       04400000
*        REGISTERS HAVE BEEN INITIALIZED FOR BXLE, ETC. FROM ITBREGS.   04480000
*        R0 = TBL                                                       04560000
*        R1 = UPPER LIMMIT OF BXLE                                      04640000
*        R2 = A(TB1)                                                    04720000
         USING ITB1,4                                                   04800000
         USING PERBUF,2                                                 04880000
ITB1     MVI   PBFLAG,FREEBIT      MARK FREE                            04960000
         LA    3,PBLAST+1          CHAIN TO NEXT                        05040000
         ST    3,PBTIC                                                  05120000
         B     ITB2                ASSUME SHORT BUFFER                  05200000
         ORG   ITB1+TBL            AVOID PBFLAG AND PBTIC               05280000
ITB2     BXLE  2,0,ITB1            LOOP BACK                            05360000
         SR    2,0                 POINT TO LAST BUFFER                 05440000
         MVI   PBTIC+1,EMPTYM      MARK AS LAST                         05520000
         BR    LINK                RETURN TO SVINIT IN APLSUP           05600000
         DROP  2,4                                                      05680000
IM       CSECT                     NOMINAL START OF WORKSPACE AREA      05760000
         DS    XL14000             MUST BE LONGER THAN 1 TRACK ON  DASD 05840000
*                                  DIRECT-ACCESS DEVICE                 05920000
SUPINI   CSECT                                                          06000000
         PRINT OFF                 COPY APLDEFN                         06080000
         COPY  APLDEFN                                                  06160000
         DROP  MR                                                       06240000
         TITLE 'LOAD AND INITIALIZE APLSUP'                             06320000
         PRINT ON,GEN                                              C021 06400000
*        SUPINI FUNCTIONS                                               06480000
*                                                                       06560000
*        A) VERSION CHECK, ESTABLISH CONFINIT ADDRESSABILITY, TIMER     07040000
*           POSSESSION CHECK, TIMER RECORD TO TEST IF RUNNING.          07200000
*        B) ZSYMDATE                                                    07280000
*        C) OPEN LIBRARY PACKS                                          07360000
*        D) OPEN SWAP AREA                                              07440000
*        E) MAX/CFREDSK                                                 07520000
*        F) TIMER CHECK AND DATE-TOD VALIDATION                         07600000
*        G) FORMAT SWAP DISK                                            07680000
*        H) COMPUTE WORKSPACE AND TYPEWRITER BUFFER PARAMETERS          07760000
*        J) SETIME TWO SECONDS, UPDATE REALTIME, MOVE SUPCONF TO APLSUP 08080000
*        K) LOAD REGISTERS FOR TYPEWRITER BUFFER SETUP AND ENTER        08480000
*           APLSUP SVINIT VIA SVC YYQZ                                  08560000
*        L) APLSUP CALLS ITB1 SUBROUTINE WHICH OVERWRITES SUPINI ETC    08640000
*           WITH TYPEWRITER BUFFERS                                     08720000
*        M) RETURN TO SVINIT CODE TO ENTER WAIT STATE AND AWAIT TIMER   08800000
*           INTERRUPT FROM SETIME TWO SECONDS IN STEP J).               08880000
*        ONE COPY PER CORE SLOT                                         10160000
PERCORE  DSECT                                                          10240000
PCQUONT  DS    1H                QUONT COUNTER                          10320000
PCADDR   DS    AL3               STARTING ADDRESS OF THIS SLOT          10400000
PCTERM   EQU   *-1               PERTERM BASE REGISTER                  10480000
         DS    AL3               HIGH ORDER BIT ON MEANS UNASSIGNED     10560000
         DS    0D                                                       10640000
PERCOREL EQU   *-PERCORE                                                10720000
SUPINI   CSECT                     SO SUPCONF WILL KNOW                 10800000
         PRINT GEN                                                      10880000
SUPPARD  APLSUPC                                                        10960000
*                                                                       11040000
VALCON   EQU   ALEN+3                                                   11680000
*                                                                       11840000
SUPINI   CSECT                                                          11920000
CUB2702  EQU   X'70'               BUSY 270X CONTROL UNIT               12000000
CSW      EQU   64                                                       12080000
Q1052    EQU   X'54'                                                    12160000
         TITLE 'LIST OF EXTERNAL ADDRESSES'                             12240000
         EXTRN APLINIT                                                  12400000
         EXTRN OPLIB               OPEN ALL LIBRARY PACKS               14320000
         EXTRN NOPEN                                                    14400000
         EXTRN DISKFMT                                                  14480000
         TITLE 'INITIALIZE APL PROGRAM'                                 14560000
*        THIS ROUTINE IS START OF APL EXECUTION                         14640000
LINK     EQU   15                                                       14720000
STAREX BALR 13,0                                                        14800000
 USING STAREX+2,13                                                      14880000
*                                                                       16480000
         ST    1,MPARM        SAVE R1 FOR LATER                         16560000
*                                                                       16640000
         LA    3,TOLIST            PASS LIST CONTAINING SUPINI'S        16720000
         ST    3,4(1)              ECB TO MOTHER TASK                   16800000
         L     1,0(1)                                                   16880000
         MVC   LIST(LISTLENG),0(1) PASS ADDRESSES TO SUPINI             16960000
         L     5,SUPLOC            RELOCATION FACTOR OF APLSUP          17120000
*        BASE REGISTERS IN SUPINI                                       17200000
*        R13   SUPINI ADDRESSABILITY                                    17280000
*        R12   SUPPARS AREA IN CONFINIT                                 17360000
         L     12,ASUPPARS         POINT TO APLSUP                      17440000
         LA    0,VALCON            FOR VERSION VALIDATION               17520000
         USING SUPPARD,12                                               17600000
         C     0,LSUPC(5)          COMPARE WITH APLSUP COPY             17680000
         LA    2,CURRENTM          SET UP ADDRESSES FOR SVCINIT         17760000
         BNE   WRONGV              APLSUP, WRONG VERSION                17840000
         L     12,ACONFINI         POINT TO CONFINIT                    17920000
         C     0,LSUPC                                                  18000000
         BNE   WRONGV              CONFIG, WRONG VERSION                18080000
*                                                                       21120000
         SPACE 3                                                    MFT 21200000
*        ALTHOUGH MFT-ATTACH IS SUPPOSED TO PROVIDE ESSENTIALLY     MFT 21280000
*        THE SAME FUNCTIONS AS MVT, THERE ARE SUBSTANTIAL           MFT 21360000
*        DIFFERENCES IN THEIR MODUS OPERANDI.                       MFT 21440000
*                                                                   MFT 21520000
*        WE WILL CHECK FOR THE TYPE OF SYSTEM BEING USED, AND IF    MFT 21600000
*        THERE IS HIERARCHY SUPPORT                                 LCS 21680000
*                                                                   MFT 21760000
*   OSFLG      HAS FOLLOWING FORMAT                                 MFT 21840000
*                                                                   MFT 21920000
*   .... XX..  R E S E R V E D                                     P062 22000000
*   X... ....  1 - PARM=DEBUG                                      P062 22080000
*   .X.. ....  1 - UNRECOGNIZED PARM                               P062 22160000
*   ..X. ....  1 - MFT-ATTACH                                       MFT 22240000
*   ...X ....  1 - MVT                                              MFT 22320000
*   .... ..X.  1 - HIARCHY 1 ONLY                                   LCS 22400000
*   .... ...X  1 - SPLIT CORE, SINI AND WSS IN LCS                  LCS 22480000
*                                                                   LCS 22560000
MFT      EQU   X'20'          MFT SYSTEM                            MFT 22640000
MVT      EQU   X'10'          MVT SYSTEM                            MFT 22720000
LCS      EQU   X'01'          SINI AND WSS IN LCS                   LCS 22800000
*                                                                   MFT 22880000
*        SINCE MVT AND MFT ASSIGN PROTECT KEYS IN THE OPPOSITE ORD  MFT 22960000
*        ER, WE HAVE TO DO DIFFERENT STUFF TO ASSIGN ACTKEY         MFT 23040000
*                                                                   MFT 23120000
*        WE'LL SET THE KEY WHILE WE'RE TESTING THE SYSTEM TYPES     MFT 23200000
*                                                                   MFT 23280000
         L     3,CVTPTR                                             MFT 23360000
         USING CVTD,3                                               MFT 23440000
         L     4,CVTTCBP      DISPATCHERS POINTER WORDS             LCS 23520000
         L     4,4(4)         CURRENT TCB ADDRESS                   LCS 23600000
         USING TCB,4                                                LCS 23680000
         LA    13,0(13)       CLEAR HI BYTE FOR LATER COMPARES          23760000
         MVC   OSFLG,CVTDCB   GET THE ONE BYTE TYPE FLAGS           MFT 23840000
         CLI   OSFLG,MVT                                            MFT 23920000
         BE    MVTSYS                                               MFT 24000000
         CLI   OSFLG,MFT                                            MFT 24080000
         BE    MFTSYS                                               MFT 24160000
*                                                                   MFT 24240000
*        AN ATTEMPT TO RUN APL ON AN OS SYSTEM OTHER THAN           MFT 24320000
*              MVT OR MFT-ATTACH                                    MFT 24400000
*                                                                   MFT 24480000
NONSS    ICALL OUTWRTL,*      TSK,TSK                               MFT 24560000
         DC    AL4(NPCP)                                            MFT 24640000
         LA    15,20          UNSUPPORTED OS SYSTEM                 MFT 24720000
         B     OSEXIT                                               MFT 24800000
*                                                                   MFT 24880000
NPCP     DC    C'APL/360-OS ONLY SUPPORTS MVT AND MFT-ATTACH'       MFT 24960000
         DC    X'FF'                                                MFT 25040000
         SPACE 3                                                    MFT 25120000
*  VALIDITY CHECK AND INITIALIZE   M F T                            MFT 25200000
*                                                                   MFT 25280000
MFTSYS   TM    CVTOPTA,X'08'  SUBTASKING SUPPORT IN THIS MFT?       MFT 25360000
*                                                                   MFT 25440000
         BZ    NONSS           NOPE.                                MFT 25520000
*                                                                   MFT 25600000
*        WE ARE RUNNING UNDER MFT-ATTACH                            MFT 25680000
         MVI   KEY2,X'F0'     ACTKEY FOR MFT                        MFT 25760000
*                                                                   MFT 25840000
*        TEST FOR HIARCHY SUPPORT IN MFT                            LCS 25920000
*                                                                   LCS 26000000
         L     5,TCBOTC           ORIGINATING TCB IS TCBMERE       3058 26080000
         L     5,TCBMSS-TCB(5)    BOUNDARY BOX FOR PARTITION       3058 26160000
         TM    0(5),X'01'     HIERARCHY SUPPORT?                    LCS 26240000
         BZ    NOH1               NO                               C032 26320000
         CLC   1(11,5),ZERO       ANY PROCESSOR CORE               3058 26400000
         BE    NOH0               SET H1 ONLY FLAG                 3058 26480000
         CLC   13(11,5),ZERO      ANY LCS?                         3058 26560000
         BE    NOH1               B IF NOT                         3058 26640000
*                                                                   LCS 26720000
*        NOTE THAT ANY SINGLE HIERARCHY PARTITION IS TREATED        LCS 26800000
*        AS 'NO HIARCHY SUPPORT'                                    LCS 26880000
*                                                                   LCS 26960000
*        THIS IS A SPLIT PARTITION, CHECK IF SINI IS IN LCS         LCS 27040000
*                                                                   LCS 27120000
         CL    13,16(5)       COMPARE SINI BASE WITH LOW            LC> 27200000
*                             END OF THE H1 PARTITION               LCS 27280000
         BL    NOH1           SINI MUST BE IN H0                    LCS 27360000
*  IF ABOVE BRANCH IS TAKEN, IT MEANS THAT ALL OF THE H1            LCS 27440000
*    PARTITION WILL BE UNUSED.                                      LCS 27520000
*                                                                   LCS 27600000
         OI    OSFLG,LCS      SET THE SPLIT PARTITION FLAG          LCS 27680000
         B     NOH1                                                 LCS 27760000
         SPACE 3                                                    LCS 27840000
*        WE ARE RUNNING UNDER MVT                                   LCS 27920000
*                                                                   LCS 28000000
MVTSYS   MVI   KEY2,X'10'     ACTKEY FOR MVT                        MFT 28080000
*                                                                   K21 28160000
*        MAKE SURE THAT SINI WAS BLOCK LOADED.                      K21 28240000
*                                                                   K21 28320000
         L     5,0(4)         RB ADDRESS INTO R5                    K21 28400000
         L     6,12(5)        ADDRESS OF CDE                        K21 28480000
         L     6,20(6)        EXTEND LIST                           K21 28560000
         CLC   4(4,6),=F'1'   SINI MUST BE BLOCK LOADED.            K21 28640000
         BNE   ABEND          OTHERWISE WE'D ABEND SOMEPLACE ELSE   K21 28720000
*                                                                   LCS 28800000
*        TEST FOR HIARCHY SUPPORT IN MVT                            LCS 28880000
*                                                                   LCS 28960000
         L     6,TCBPQE       ADDRESS OF DPQE-8                     LCS 29040000
         CLC   9(3,6),13(6)   MORE THAN ONE PQE?                    LCS 29120000
         BNE   LOOP           SPLIT REGION                          LCS 29200000
*                                                                   LCS 29280000
*        ANY SINGLE HIERARCHY REGION IS TREATED AS                  LCS 29360000
*        'NO HIARCHY SUPPORT'.                                      LCS 29440000
*                                                                   LCS 29520000
         L     6,8(6)         GET PQE ADDRESS                       LCS 29600000
         TM    29(6),X'01'    ALL IN LCS?                           LCS 29680000
         BZ    NOH1           ALL PROCESSOR CORE                    LCS 29760000
NOH0     OI    OSFLG,LCS+LCS  ALL IN LCS                            LCS 29840000
         B     NOH1                                                 LCS 29920000
         SPACE 3                                                    LCS 30000000
LOOP     L     6,8(6)         GET NEXT PQE ADDRESS                  LCS 30080000
         LTR   6,6            END OF PQE CHAIN?                     LCS 30160000
         BZ    ABEND          SHOULD NEVER HAPPEN                   LCS 30240000
         L     8,24(6)        START OF REGION                           30320000
         L     9,20(6)        LENGTH OF REGION                          30400000
         AR    9,8            END ADDRESS                           LCS 30480000
         CR    13,8           BEFORE START OF THIS SECTION          LCS 30560000
         BNH   LOOP           ALSO SHOULDN'T HAPPEN                 LCS 30640000
         CR    13,9           AFTER END OF THIE REGION?             LCS 30720000
         BH    LOOP           LOOK AT NEXT PQE                      LCS 30800000
*                                                                   LCS 30880000
*        THIS IS IT                                                 LCS 30960000
*                                                                   LCS 31040000
         TM    29(6),X'01'    H1?                                   LCS 31120000
         BZ    NOH1           IF THIS IS 0 AFTER ALL THIS,          LCS 31200000
*              IT MEANS ALL OF THE H1 CORE IS LYING FALLOW.         LCS 31280000
         OI    OSFLG,LCS      SET THE SPLIT REGION FLAG.            LCS 31360000
*                                                                   LCS 31440000
         DROP  3,4                                                  LCS 31520000
NOH1     EQU   *              OSFLG IS NOW INITIALIZED.             LCS 31600000
         SPACE 3                                                    LCS 31680000
         LA    3,WLEN              OPLIB,NOPEN, ETC                     31760000
         LA    4,KMHASH            FROM POINTERS IN MOTHER LIST         31840000
         STM   2,4,ACURRENT                                             31920000
DCBLGTH  EQU   72                                                       32000000
         L     MR,=A(IM)                                                32080000
         ST    MR,0(2)             SAVE IM ADDRESS                      32160000
         ST    2,LISTLENG(1)       PEACOCK CURRENTM.                    32240000
         LM    2,3,ALIBPZ          PARAMETERS FOR MAX CFREDSK           32320000
         STM   2,3,CDCBXLE+4                                            32400000
*                                  THIS MUST BE ADDR OF SVOLDPS IN      32480000
         LA    1,ASVOLDPS-LIST(1)  MOTHER. NOTE ASSUMPTIONS THAT        32560000
*                             R1 HAS NOT BEEN MISUSED                   32640000
         SR    0,0                                                      32720000
         SVCC  INIT                                                     32800000
*        HALT ALL 270X LINES.                                           32880000
         SVRAPE                                                         32960000
         BAL   5,HIOL                                                   33040000
         B     TIME                                                     33120000
*        FOLLOWING CODE IS SIMILAR TO APLCNCL IN ASUP.                  33200000
         EXTRN MPXCH                                               5991 33280000
MPXCHANL DC    AL3(MPXCH-APLSVC)                                   5991 33360000
         ORG   *-1                                                 5991 33440000
HIOL     LM    0,2,PTBXLE          LENGTH,LAST,FIRST                    33520000
         LH    3,MPXCHANL          CHANNEL ADDRESS                 5991 33600000
         USING PERTERM,2                                                33680000
HIO      CLI   PTTYPE,0            IGNORE DUMMY ENTRIES.                33760000
         BE    HIO2                                                     33840000
         CLI   PTTYPE,Q1052        IGNORE NON-270X DEVICES.             33920000
         BNL   HIO2                                                     34000000
         IC    3,PTUNAD            PICK UP UNIT ADDRESS.                34080000
HIO1     MVI   CSW+4,0             CLEAR DEVICE STATUS.                 34160000
         HIO   0(3)                                                     34240000
         TM    CSW+4,CUB2702                                            34320000
         BO    HIO1                TRY AGAIN.                           34400000
HIO2     BXLE  2,0,HIO             NEXT PERTERM.                        34480000
         BR    5                                                        34560000
         DROP  2                                                        34640000
TIME     EQU   *                                                        34720000
         SPACE 2                                                        34800000
*                                                                       34880000
*              CONVERT CURRENT DATE TO APL FORM AVOIDING THE USE OF     34960000
*              PACKED DECIMAL ARITHMETIC FOR THE SAKE OF THE MODEL 91   35040000
*              THIS PIECE OF CODE IS REUSABLE SO THAT IT MAY BE USED IN 35120000
*              APLSUP AT SOME LATER DATE                                35200000
*                                                                       35280000
         TIME  DEC                 GET PACKED DATE                      35360000
         ST    1,DATE              AND                                  35440000
         STH   1,DAY+6             SAVE IT                              35520000
         CVB   1,DAY               FORM BINARY DAY OF YEAR              35600000
         LM    2,5,INDEX           INDICES FOR CALCULATING MONTH        35680000
         TM    DATE+1,X'01'        CHECK FOR LEAP YEAR                  35760000
         BO    CMP                 THIS IS AN ODD YEAR                  35840000
         TM    DATE+1,X'12'        FIND EVEN NON LEAP YEARS. THIS       35920000
         BM    CMP                 CODE IS VALID UNTIL THE YEAR 2100    36000000
         CH    1,NUMTH+2(4)        A LEAP YEAR. IS THIS BEFORE FEB 29TH 36080000
         BL    CMP                 YES                                  36160000
         BZ    PRT                 NO, BUT IT IS FEB 29TH               36240000
         BCTR  1,0                 DATE AFTER 29TH FEB IS 1 DAY TOO HI  36320000
CMP      CH    1,NUMTH(4)          IS DAY IN THIS MONTH                 36400000
         BL    DEC                 EXIT FROM SEARCH IF YES              36480000
         BXLE  4,2,CMP             GO TEST NEXT MONTH IN LIST TO DEC.   36560000
DEC      SR    4,2                 ADJUST MONTH                         36640000
PRT      SH    1,NUMTH(4)          FORM DAY OF MONTH                    36720000
         AH    1,NUMTH                                                  36800000
         AR    2,4                 FORM BINARY DATE                     36880000
         MR    4,2                 (100*MONTH)+DAY                      36960000
         AR    1,5                                                      37040000
         CVD   1,DECDT             PACKED DECIMAL DATE IN FORM          37120000
         OI    DECDT+7,X'0F'                                            37200000
         MVC   DECDT+4(1),DATE+1   YY0MMDDS                             37280000
         L     2,AZSYMDAT          CONVERT DATE TO EBCDIC               37360000
         UNPK  DATE(7),DECDT+4(4)  WITH INTERSPERSED SLASHES            37440000
         MVC   0(8,2),=AL1(3,4,7,5,6,7,0,1)                             37520000
         TR    0(8,2),DATE                                              37600000
         L     1,ATYI1052                                               37760000
         TR    0(8,2),0(1)         TRANSLATE FROM EBCDIC                37840000
         TIME  TU                  TOD NOW                         5986 38240000
INPCA    ST    0,INITIM            FOR TIMER CHECK                      38400000
         TITLE 'PERFORM STORAGE ALLOCATION OF BUFFERS AND WORKSPACES'   38480000
*                                                                       38560000
*        PERFORM STORAGE ALLOCATION FOR TYPEWRITER BUFFERS AND WORKSP'S 38640000
*                                                                       38720000
* INPCA0.. R4 IS R3 IS (F1LOWADDR+F1SIZE)-SLOTS*WSLENR                  38800000
*        PCADDR(IOTA SLOTS) IS R3+WSLENR*IOTA SLOTS                     38880000
*        FREEBC IS FLOOR (R4-A(TYBUFG) ) DIV TBL                        38960000
*        GOTO (FREEBC LSS MINBUF)/INPCA2                                39040000
*        SETUP FOR TYPEWRITER BUFFER CREATION                           39120000
*        R0 IS TBL                                                      39200000
*        R1 IS R4-TBL                                                   39280000
*                                                                       39360000
* INPCA2.. GOTO (2 GEQ SLOTS IS SLOTS-1)/INPCA0                         39440000
*        QUAD IS 'TOO FEW CORE SLOTS'                                   39520000
*                                                                       39600000
         L     1,CVTPTR       GET TCB ADDRESS                           45280000
         USING CVTD,1                                                   45360000
         L     1,CVTTCBP      FROM CVT POINTER                          45440000
         DROP  1                                                        45520000
         L     1,4(1)                                                   45600000
         MVC   INACTKEY,TCBPKE-TCB(1) SAVE STORAGE PROTECT KEYS         45680000
         MVC   ACTKEY,KEY2                                          MFT 45760000
         NC    GETMLCSF(1),OSFLG   LEAVE H1 FLAG ON ONLY IF WE'RE       45840000
*                                  IN A SPLIT REGION                    45920000
*        GETMAIN MF=(E,GETMLIST)   GET ALL AVAILABLE CORE           K13 46000000
         LA    1,GETMLIST     LOAD PARAMETER REGISTER 1             K13 46080000
         SVC   4              GETMAIN                               K13 46160000
         LTR   15,15               SEE IF                               46240000
         BNE   OVFLOW              CORE WAS OBTAINED                    46320000
         LM    0,1,SPACES          GET AMOUNT OF STOARGE AND ADDRESS    46400000
         AR    1,0                 CALCULATE HIGH ADDRESS               46480000
         LR    0,1                                                      46560000
&SLOP    SETA  (&SLOP+2047)/2048*2048                                   46640000
         S     1,=A(&SLOP)                                              46720000
*                                                                       46800000
         L     2,MPARM                                                  46880000
         OC    OSFLG(1),8(2)       COPY FLAG AS PASSED FROM MOTHER P062 46960000
         TM    OSFLG,X'01'         SPLIT?                          P062 47040000
         BO    DEBUGX              YES                             P062 47120000
         TM    OSFLG,X'80'         DEBUG?                          P062 47200000
         BZ    DEBUGX              NO.                             P062 47280000
         S     1,=A(4*2048)        FREE 8K MORE FOR DEBUG.         P062 47360000
DEBUGX   EQU   *                                                   P062 47440000
*                                                                       47520000
         N     1,=F'-2048'    ROUND DOWN TO 2K BOUNDARY                 47600000
         SR    0,1                 FREE THAT NOT REQD                   47680000
         ST    1,SPACES+8                                               47760000
*        FREEMAIN R,LV=(0),A=(1),                                   K13 47840000
         LA    1,0(1)         LOAD PARAMETER REGISTER 1 AND CLEAR   K13 47920000
         SVC   10             REGISTER FORM GETMAIN                 K13 48000000
         SPACE 2                                                   P062 48080000
INPCA0   L     3,SPACES+8          HI ADDRESS OF WORKSPACES AND BUFFERS 48160000
         L     0,SLOTS             RHO PERCORE                          48560000
         LH    5,INPCA                                                  48640000
         L     1,AWSLENR           2048*CEIL WSLENGTH DIV 2048          48720000
         SR    3,1                 COMPUTE WS ORG                       48800000
         BCT   0,*-2               LOOP FOR ALL SLOTS                   48880000
         LR    4,3                 R4 POINTS TO FIRST WORKSPACE         48960000
         SLR   1,5                                                      49040000
         LR    5,1                                                      49120000
*        ITERATE THROUGH PERCORE, SETTING PCADDR                        49200000
         LM    0,2,PCBXLE                                               49280000
         USING PERCORE,2                                                49360000
INPCA1   ST    3,BUCK3-1                                                49440000
         MVC   PCADDR,BUCK3                                             49520000
         A     3,AWSLENR                                                49600000
         BXLE  2,0,INPCA1                                               49680000
         DROP  2                                                        49760000
         ST    4,CURRENTM          FIRST SLOT IS THROWAWAY AREA FOR     49840000
         ST    4,PTBASE            SUPINI'S QUANTUM END                 49920000
         ST    4,FINALMR                                                50000000
         LR    1,4                                                      50080000
         S     1,=A(TYBUFG)        R1 IS SPACE FOR TYPEWRITER BUFFERS   50160000
         BNP   INPCA2              NO SPACE FOR TYBUFS                  50240000
         SR    0,0                                                      50320000
         D     0,=A(TBL)                                                50400000
         ST    1,FREEBC            FREE BUFFER COUNT                    50480000
         C     1,KMINBUF           MINIMUM BUFFER REQUIREMENT FROM CONF 50560000
         BL    INPCA2              NOT ENOUGH SPACE FOR BUFFERS         50640000
         MH    1,KOVERBOK+2        MULTIPLY BY OVERBOOK FACTOR FOR      50720000
         ST    1,KOVERBOK          POSOM USE IN APLSUP                  50800000
*        SETUP R0,R1,R2,R4 FOR ITB1 USAGE                               50880000
         SRA   5,28                                                     50960000
         LA    0,TBL                                                    51040000
         LR    1,4                                                      51120000
         SR    1,0                 FOR BXLE STOPPER                     51200000
         L     2,=A(TYBUFG)                                             51280000
         ST    2,FREEBA            FOR GETBUF IN APLSUP                 51360000
         LA    4,ITB1-TYBUFG(2)    BASE REG FOR ITB1                    51440000
         STM   0,5,ITBREGS         FOR LATER RELOADING                  51520000
*        FORMAT TYPEWRITER MESSAGE                                      51600000
         L     0,SLOTS             DISPLAY ACTUAL PARAMETERS            51680000
         CVD   0,CVDTEM                                                 51760000
         UNPK  DSLOTS(2),CVDTEM+6(2)                                    51840000
         CLI   DSLOTS,C'0'                                              51920000
         BNE   *+8                                                      52000000
         MVI   DSLOTS,C' '         LEADING ZERO SUPPRESSION             52080000
         OI    DSLOTS+1,C'0'                                            52160000
         L     0,FREEBC            FREE BUFFER COUNT                    52240000
         CVD   0,CVDTEM                                                 52320000
         UNPK  DFBC(4),CVDTEM+5(3)                                      52400000
         OI    DFBC+3,C'0'                                              52480000
         B     COREOK              ENOUGH CORE TO RUN                   52560000
*        TOO MANY WORKSPACES, NOT ENOUGH TYPEWRITER BUFFERS.            52640000
*        DECREMENT SLOTS AND TRY AGAIN.                                 52720000
INPCA2   LM    0,3,PCBXLE                                               52800000
         BCTR  3,0                                                      52880000
         SR    1,0                 BXLE STOPPER                         52960000
         STM   0,3,PCBXLE                                               53040000
         BCT   3,INPCA0            BR WHILE SLOTS GE 2             C045 53200000
*        SLOTS HAS BECOME ONE, EVIL                                     53520000
*        INSUFFICIENT CORE STORAGE ASSIGNED.                            53600000
         B     OVFLOW                                                   53680000
         TITLE 'OPEN LIBRARY FILES AND CHECK TIMER'                     53760000
COREOK   EQU   *                                                        53840000
         USING CDCPARS,7                                                54000000
         L     7,ASWAPPAR                                               54080000
         LH    7,LOGAD                                                  54160000
         USING IHADCB,7                                                 54240000
         LA    6,DCBLGTH                                                54320000
         MR    6,6                                                      54400000
         A     7,AAPLSDCB                                               54480000
         OI    DCBMACRF+8,X'20'    SET END APP FLAG ON IN SWAPDCB       54560000
         STM   0,2,TEM4                                                 54640000
*                                                                       54720000
*   THE APL PSEUDO APPENDAGES MUST NOW BE IDENTIFIED TO OS              54800000
*                                                                       54880000
*        SINCE APPENDAGES ARE LOADED BY OPEN, AND LOAD RECOGNIZES       54960000
*        THE PREVIOUS EXISTENCE OF A MODULE, WE WILL LOAD THE           55040000
*        APL PSEUDO APPENDAGE, MODIFY AN INTERNAL ADDRESS CONSTANT      55120000
*        SO THEY CAN TRANSFER CONTROL TO THE REAL APL APPENDAGES.       55200000
*                                                                       55280000
*        THE ABOVE DESCRIBED MESS IS NECESSARY BECAUSE MFT DOES         55360000
*        NOT RECOGNIZE AN IDENTIFY'D ENTRY POINT WHEN PROCESSING        55440000
*        A LOAD.                                                        55520000
*                                                                       55600000
*  BEFORE DOING BLDL, MOVE IN CORRECT APPENDAGE NAMES FROM SWAPDCB      55680000
*                                                                       55760000
         MVC   PCI+6(2),DCBPCIA                                         55840000
         MVC    CE+6(2),DCBCENDA                                        55920000
         MVC    XE+6(2),DCBXENDA                                        56000000
*                                                                       56080000
         BLDL  0,BLDLIST      SEARCH THE JOBLIB DIRECTORY FOR THE       56160000
*                             APPENDAGE ENTRY POINTS.  THIS IS          56240000
*                             DONE SO WE CAN DIE GRACEFULLY IF          56320000
*                             MODULES ARE NOT FOUND.                    56400000
*                                                                       56480000
         LTR   15,15                                                    56560000
         BNZ   BLDLFAIL         B. IF AT LEAST 1 UNSUCCESSFUL           56640000
*                                                                       56720000
*  SINCE THE BLDL WAS SUCCESSFUL,WE OUGHT TO BE ABLE TO LOAD            56800000
*                                                                       56880000
         LOAD  DE=PCI                                                   56960000
         ST    0,DAPAD             SAVE APP ADD                    2212 57040000
         LOAD  DE=CE                                                    57120000
         ST    0,DAPAD+4                                           2212 57200000
         LOAD  DE=XE                                                    57280000
         ST    0,DAPAD+8                                           2212 57360000
*                                                                       57440000
*   THE PSEUDO APPENDAGES HAVE BEEN LOADED, BUT NOT INITIALIZED    2212 57520000
*                                                                       57600000
         LM    0,2,CDCBXLE                                              57680000
         USING CDCPARS,2                                                57760000
FLAGON   LH    7,LOGAD                                                  57840000
         LA    6,DCBLGTH                                                57920000
         MR    6,6                                                      58000000
         A     7,AAPLSDCB                                               58080000
         OI    DCBMACRF+8,X'20'    TURN ON END APPENDAGE FLAG           58160000
         BXLE  2,0,FLAGON                                               58240000
         DROP  2,7                                                      58320000
         LM    0,2,TEM4                                                 58400000
         ICALL OPLIB               OPEN ALL LIBRARY PACKS               58560000
         L     8,ADPAR                                                  58640000
         USING CDCPARS,8                                                58720000
         L     0,TLENF                                                  59120000
         STH   0,RDCCW+6                                                59200000
*                                                                       59280000
         L     0,KMHASH            NUMBER OF DIRECTORIES                59360000
         LH    7,LOGAD                                                  59760000
         LA    6,DCBLGTH                                                59840000
         MR    6,6                PERFORM ALGORITHM ON LOGAD TO FIND    59920000
         A     7,AAPLSDCB                                               60000000
         ST    7,DCBN             STORE DCB ADDR. INTO IOB              60080000
         DROP  8                                                        60240000
         L     3,ADIRTAB                                                60320000
DIRLP1   MVC   CCHH,0(3)                                                60400000
         STM   0,3,TEM4                                                 60480000
         MVC   IOB+35(4),CCHH     INITIALIZE BBCCHHR IN IOB FOR STAND   60960000
*                                                ALONE SEEK             61040000
         USING IHADCB,7                                                 61120000
         MVC   DCBIOBAD(4),=A(IOB)    MOVE IOB ADDR. INTO DCB           61200000
         MVI   ECB,0                                                    61280000
         EXCP  IOB                                                      61360000
         WAIT  ECB=ECB                                                  61440000
         CLI   ECB,X'7F'      NORMAL COMPLETION ?                  2212 61520000
         BNE   IOABEND                                             2212 61600000
         L     3,CDCBXLE+12        DIRECTORY BASE                  C037 61760000
*                                                                  C037 61840000
*  DO SOME TRIVIAL VALIDITY CHECKING TO VERIFY THAT WE ARE         C037 61920000
*  ACTUALLY READING APL DIRECTORIES                                C037 62000000
         SR    2,2                 ERR CODE FOR NON-DIRECTORY      C037 62080000
         CLC   APLDIR(20),WFLLIB-M(3) IS THIS THE RIGHT DIRECTORY  C037 62160000
         BNE   DIRERR              IF NOT, GIVE ERROR MESSAGE      C037 62240000
         L     4,APLDIR            GET THE DIRECTORY NUMBER        C037 62320000
         LA    4,1(4)              INCREMENT IT BY ONE             C037 62400000
         ST    4,APLDIR            AND STORE BACK FOR NEXT PASS    C037 62480000
         ST    4,APLDIR+16         WE CHECK BOTH SIDES             C037 62560000
         LA    2,4                 ERR CODE IF DIR FORMAT WRONG    C059 62640000
         CLC   VVMM-M(4,3),=C'V1M1' DIRS WRITTEN WITH V1M1 UTIL?   C059 62720000
         BNE   DIRERR              NO.  INCOMPATIBLE DIR FORMATS   C059 62800000
         LA    2,8                 ERR CODE IF COUNTS WRONG        C059 62880000
         L     4,KMHASH            NO. DIRS FROM CONFIG            C059 62960000
         LA    5,1000                                              C059 63040000
         A     5,QR13STK-M(3)      ACTUAL WS LENGTH                C059 63120000
         C     4,NUMDIRS-M(3)      ACTUAL DIRS VS. CONFIG DIRS     C059 63200000
         BNE   DIRERR              MISMATCH.  LET'S QUIT           C059 63280000
         C     5,WLEN              ACTUAL WSLEN VS. CONFIG WSLEN   C059 63360000
         BNE   DIRERR              MISMATCH.  LET'S QUIT           C059 63440000
         LM    0,2,CDCBXLE                                         C059 63520000
         USING CDCPARS,2                                                63600000
         LA    3,FREEDSK-M(3)                                           63680000
DIRLP3   CLC   CFREDSK,0(3)                                             63760000
         BH    DIRLP4                                                   63840000
         MVC   CFREDSK,0(3)                                             63920000
DIRLP4   LA    3,4(3)                                                   64000000
         BXLE  2,0,DIRLP3                                               64080000
         DROP  2                                                        64160000
         LM    0,3,TEM4                                                 64240000
DIRLP2   LA    3,8(3)                                                   64320000
         BCT   0,DIRLP1            READ NEXT DIRECTORY                  64400000
*        CFREDSK IS INITIALIZED                                         64480000
*                                                                       64560000
*        IF HTAB =0 THEN HISTOGRAM CSECT HAS NOT BEEN LOADED.           64640000
*        FOLLOWING CODE WILL KILL HISTOGRAMS BY  CHANGING A  BCR 0,0    64720000
*        AT THE BEGINNING OF HISTCOMP IN APLSUP TO A BCR 15,15          64800000
         L     1,AHISTKIL                                               64880000
         A     1,SUPLOC            TRUE LOCATION OF APLSUP DURING INIT  64960000
         L     0,AHTAB             SEE IF WE WERE LINKEDITED WITHOUT    65040000
         LTR   0,0                 HISTOGRAM STORAGE SPACE              65120000
         BNZ   *+8                                                      65200000
         MVI   1(1),X'FF'          KILL HISTOGRAMS                      65280000
         TIME  TU                  TOD NOW SHOULD NOT BE SAME NOW  5986 65760000
         C     0,INITIM            AS IT WAS EARLIER.              5986 65840000
         BNE   TIMEROK                                                  66000000
         TITLE 'ERROR CONDITIONS'                                       66080000
         ICALL OUTWRTL,*      TIMER NOT RUNNING                     K04 67840000
         DC    AL4(TIM1)                                            K04 67920000
         LA    15,12                                                K03 68000000
         B     OSEXIT                                               K03 68080000
*                                                                   K03 68160000
OVFLOW   ICALL OUTWRTL,*      INSUFFICIENT CORE STORAGE             K04 68240000
         DC    AL4(OVFMSG)                                          K04 68320000
         LA    15,4                                                 K03 68400000
         B     OSEXIT                                               K03 68480000
*                                                                   K03 68560000
WRONGV   ICALL OUTWRTL,*      MISMATCH OF APL MODULES               K04 68640000
         DC    AL4(WRVT)                                            K04 68720000
         LA    15,8                                                 K03 68800000
*                                                                   K03 68880000
*  SUPINI HAS DETECTED AN UNTENABLE ENVIRONMENT.                    K03 68960000
*        IT WILL TERMINATE WITH A NON-ZERO COMPLETION CODE          K03 69040000
*                                                                   K03 69120000
OSEXIT   SVC   EXIT                                                 K03 69200000
         SPACE 3                                                    K03 69280000
EXIT     EQU   3                                                    K03 69360000
*                                                                       69440000
*        THE BLDL OPERATION FAILED, WE WILL BE UNABLE TO BRING UP APL   69520000
*                                                                       69600000
BLDLFAIL STC   15,BLDLFC+1    SAVE RC                                   69680000
         UNPK  BLDLFC(3),BLDLFC+1(2)                                    69760000
         TR    BLDLFC(2),HEXTAB                                         69840000
         MVI   BLDLFC+2,X'FF'                                           69920000
         ICALL OUTWRTL,*                                                70000000
         DC    AL4(BLDLF)                                               70080000
         LA    15,16                                                    70160000
         B     OSEXIT                                                   70240000
         SPACE 3                                                        70320000
IOABEND  ABEND 1099,DUMP           QUICK AND DIRTY ERROR HANDLING  2212 70400000
DIRERRAB ABEND 1098,DUMP           BAD DIRECTORIES                 2212 70480000
*                                                                       70560000
*        WE GOT CONFUSED WHEN LOOKING AT THE CORE LAYOUT.               70640000
*                                                                       70720000
ABEND    ICALL OUTWRTL,*      PRINT ERROR MESSAGE.                      70800000
         DC    AL4(HELP)                                                70880000
         ABEND 1090,DUMP                                                70960000
*                                                                       71040000
HELP     DC    C'CORE FRAGMENTATION WITHIN APL REGION/PARTITION'        71120000
         DC    X'FF'                                                    71200000
         DC    0H'0'          FOR ALIGNMENT                             71280000
*                                                                  C037 71440000
*  AN INVALID NUMBER OF DIRECTORIES                                C037 71520000
*                                                                  C037 71600000
DIRERR   ST    2,DERRTEMP          OUTWRTL CLOBBERS R2             C059 71680000
         ICALL OUTWRTL,*           'INCOMPATIBLE LIB FMT'          C059 71760000
         DC    AL4(DIRERRM)                                        C037 71840000
         L     2,DERRTEMP          R2 HAS OUR ERROR CODE           C059 71920000
         L     6,WLEN              WSSIZE FROM CONFIG              C059 72000000
         L     3,NUMDIRS-M(3)      ACTUAL DIRS                     C059 72080000
         B     DIRERRAB            GO GIVE DUMP                    C037 72160000
         TITLE 'COMPLETE THE INITIALISATION'                            72240000
TIMEROK  EQU   *                                                        72320000
*        PREFORMAT SWAP AREA                                            72400000
*                                                                       72480000
         L     8,ASWAPPAR                                               72560000
         L     9,=A(NOPEN)                                              72640000
         BALR  15,9                                                     72720000
         L     1,ACONFSWA          FORMAT SWAP DISK                     72800000
         L     15,=A(DISKFMT)                                           72880000
         BALR  15,15                                                    72960000
         SR    0,0                ZERO GR0                              73840000
         SPM   0                  SET PROGRAM MASK TO ZERO              73920000
         TIME  TU                                                   R4: 74000000
         SRDL  0,39                                                 R4: 74080000
         ST    1,REALTIME                                               74160000
         MVC   SYSPARS+1(1),OSFLG SAVE IT FOR THE DUMP             C037 74240000
*        MOVE SUPCONF FROM CONFIG TO APLSUP                             74400000
         L     1,ASUPPARS                                               74480000
         A     1,SUPLOC            FOR STAND ALONE                      74560000
         MVC   4(ALEN,1),PTBXLE    CONFINIT PARAMETERS TO APLSUP        74640000
         L     1,ACONFINI     CONFINIT IS NO LONGER NEEDED          K10 77600000
         L     2,APCSUB       APL'S PROGRAM CHECK HANDLER           K10 77680000
         SPIE  (2),((1,15)),MF=(E,(1))                              K10 77760000
*                                                                  2212 78000000
*        ESTABLISH LINK TO APPENDAGES IN ASUP                      2212 78080000
*                                                                  2212 78160000
         L     5,MPARM        POINTER TO TRUE APP. ADDRESSES       2212 78240000
         L     1,DAPAD        FIRST DUMMY APP                      2212 78320000
         MVC   8(4,1),12(5)                                        2212 78400000
         L     1,DAPAD+4                                           2212 78480000
         MVC   8(4,1),16(5)                                        2212 78560000
         L     1,DAPAD+8                                           2212 78640000
         MVC   8(4,1),20(5)                                        2212 78720000
         ICALL OUTWRTL,*                                            K04 78800000
         DC    AL4(RMSG)                                            K04 78880000
         L     1,MOTHER       GET THE ADDRESS OF  ECBMERE           K03 78960000
         POST  (1)            TELL APLM THAT SINI HAS FINISHED      K03 79040000
         WAIT  ECB=ECBSUP                                               79120000
*        ENTER APLSUP VIA QUEND.                                        79280000
         L     MR,FINALMR                                               79360000
         LM    0,5,ITBREGS                                              79440000
         SVCC  YYQZ                                                     79520000
         TITLE 'OUTWRTL - OUTPUT MESSAGE TO SYSTEM OPERATOR   05/11/70' 79600000
*                                                                       79680000
*        THIS OUTWRTL IS A SIMPLE-MINDED VERSION OF THE OUTWRTL         79760000
*        IN URSECT OF THE APL UTILITY.  THE MESSAGE IS SENT ONLY TO THE 79840000
*        SYSTEM OPERATOR WITH NO REPLY REQUIRED.                        79920000
*                                                                       80000000
*        CODES X'FA' TO X'FF' ARE USED FOR END OF MESSAGE.  ALL OTHER   80080000
*        CHARACTERS ARE TREATED AS TEXT.                                80160000
*        R0, R1, & R2 ARE USED.  RETURN IS TO 4 + R15.                  80240000
*        CALLED BY   ICALL OUTWRTL   FOLLOWED BY   DC AL4(TEXTADDR)     80320000
*                                                                       80400000
         ENTRY OUTWRTL                                                  80480000
OUTWRTL  BALR  2,0                 SHORTENED FORM OF PROLOG             80560000
         USING *,2                                                      80640000
         MVC   OUTWTEMP(4),0(15)   TEXT ADDRESS MIGHT NOT BE ALIGNED    80720000
         L     1,OUTWTEMP          PICK UP ADDRESS OF TEXT              81040000
         MVC   OUTWMSG(130),0(1)   MOVE MESSAGE INTO BUFFER             81120000
OUTWRTA  LR    0,1                 POINT TO LAST NON-BLANK CHARACTER    81200000
OUTWRTB  CLI   0(1),X'FA'                                               81280000
         BNL   OUTWRTC             WE HAVE FOUND THE END OF TEXT        81360000
         CLI   0(1),X'40'          AVOID PRINTING TRAILING BLANKS       81440000
         LA    1,1(0,1)            LOOK AT NEXT CHARACTER NEXT TIME     81520000
         BNE   OUTWRTA                                                  81600000
         B     OUTWRTB                                                  81680000
OUTWRTC  S     0,OUTWTEMP          CALCULATE EFFECTIVE LENGTH OF TEXT   81760000
         AH    0,=H'12'       OS WANTS COUNT 4 GREATER THAN IT IS,  K04 82720000
*              AND THERE IS AN 8 DIGIT MESSAGE HEADER.              K04 82800000
         ST    15,OUTWTEMP    AND IT WANTS TO USE REG. 15           K04 82880000
         STH   0,OUTWMSGG          PUT COUNT INTO MESSAGE HEADER        82960000
         LA    1,OUTWMSGG                                               83040000
         AR    1,0            ADDRESS OF END OF TEXT                K04 83120000
         MVC   0(4,1),=X'00008020' MCS FLAGS FOR ROUTCDE=(1,11)     K04 83200000
         LA    1,OUTWMSGG     WTO PARAMETER LIST                    K04 83280000
         SVC   35                  WTO MACRO EXPANSION                  83360000
         L     15,OUTWTEMP         RESTORE REG. 15 BEFORE BRANCHING K04 83440000
         B     4(0,15)             RETURN TO CALLER                     83520000
         DROP  2                                                        83600000
*                                                                       83680000
OUTWMSGG DC    0F'0',AL2(*-*),XL2'8000' MSG LENGTH, MCS FLAG        K04 83760000
OUTWMSH  DC    CL8'APL'       MESSAGE HEADER FOR CONSOLE MESSAGES       83920000
OUTWMSG  DC    130C'*',X'FF'       MESSAGE TEXT BUFFER                  84000000
OUTWTEMP DC    A(*-*)              TEMP STORAGE AREA FOR ALIGNMENT      84080000
DERRTEMP DS    F                   SAVE R2 BEFORE OUTWRTL          C059 84160000
*                                                                       84240000
         TITLE 'IO CONTROL BLOCKS AND OTHER CONSTANTS'                  84320000
TIM1     DC    C'INTERVAL TIMER NOT STEPPING.  '                    K04 84400000
         DC    C'PLEASE ENABLE AND SET CLOCK.',X'FF'                K04 84480000
OVFMSG   DC    C'INSUFFICIENT CORE STORAGE.',X'FF'                  K04 84560000
WRVT     DC    C'MISMATCH OF APL MODULES',X'FF'                     K04 84640000
DIRERRM  DC    C'INCOMPATIBLE APL LIBRARY FORMAT',X'FF'            C037 84720000
APLDIR   DC    F'0',C'APLDIRECTORY',F'0'                           C037 84800000
         PRINT NOGEN                                                    86640000
         DCBD  DSORG=(DA,XA)                                            86720000
CVTD     DSECT                                                          86800000
         CVT   SYS=MVT                                                  86880000
         SPACE 2                                                    MFT 86960000
TCB      DSECT                                                          87040000
TCBPKE   EQU   TCB+28                                                   87120000
TCBOTC   EQU   TCB+X'84'                                           3058 87200000
TCBPQE   EQU   TCB+X'98'                                                87280000
TCBMSS   EQU   TCB+X'18'                                                87360000
SUPINI   CSECT                                                          87440000
         PRINT ON,GEN                                                   87520000
*  TOLIST TO TOLISTZ IS MOVED TO APLM BY APLM                           87600000
TOLIST   DC    A(ECBSUP)                                                87680000
OSFLG    DC    X'00'          OS TYPE AND LCS FLAGS                     87760000
KEY2     DC    X'FF'          ACTKEY                                    87840000
TOLISTZ  EQU   *                                                        87920000
ECBSUP   DC    F'0'                                                     88000000
LENGTH   DC    A((2*20480)-22000)  MINIMUM EXTRA CORE FOR 2 WS SYS DASD 88080000
*              MINIMUM WSS IS 20480, APP SIZE OF APLSINIT IS 22000 DASD 88160000
         DC    X'00FFFF00'             MAXIMUM AMOUNT                   88240000
SPACES   DC    3A(EMPT3)                                                88320000
ZERO     DC    XL11'00'           TEST FOR LCS IN MFT              3058 88400000
         SPACE 3                                                        88480000
GETMLIST GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=1,MF=L,SP=0         C069 88560000
GETMLCSF EQU GETMLIST+4            HIAR BYTE                            88640000
         SPACE 3                                                        88720000
GETMAIN  DSECT                                                          88800000
         SPACE 3                                                        88880000
         GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=0,MF=L                   88960000
         SPACE 3                                                        89040000
         GETMAIN VC,LA=LENGTH,A=SPACES,HIARCHY=1,MF=L                   89120000
         SPACE 3                                                        89200000
SUPINI   CSECT                                                          89280000
         SPACE 3                                                        89360000
*                                                                       89440000
*  CONSTANTS AND LISTS FOR PSEUDO IDENTIFY.                             89520000
*                                                                       89600000
         SPACE 3                                                        89680000
BLDLF    DC    C'BLDL FOR PSEUDO APPENDAGES FAILED, RC='           KHG  89760000
BLDLFC   DC    C'XX'                                                    89840000
         DC    X'FF'                                                    89920000
BLDLIST  DC    H'3,58'        # OF ENTRIES,LENGTH OF EACH               90000000
PCI      DC    C'IGG019$$'    PCI                                       90080000
         DC    XL50'00'                                                 90160000
CE       DC    C'IGG019$$'    CE                                        90240000
         DC    XL50'00'                                                 90320000
XE       DC    C'IGG019$$'    ABNORMAL END                              90400000
         DC    XL50'00'                                                 90480000
*                                                                       90560000
         SPACE 3                                                        90640000
HEXTAB   EQU   *-C'0'                                                   90720000
         DC    CL16'0123456789ABCDEF'                                   90800000
         SPACE 3                                                        90880000
MPARM    DC    A(EMPT3)                                                 90960000
DAPAD    DC    3A(EMPT3)           DUMMY APPENDAGE ARE             2212 91040000
EMPT3    EQU   X'800000'                                                91120000
IOB      DC    X'42000000'                                              91200000
         DC    X'00'                                                    91280000
         DC    AL3(ECB)                                                 91360000
         DC    2F'0'                                                    91440000
         DC    X'00'                                                    91520000
         DC    AL3(RD1TKW)                                              91600000
DCBN     DS    F                                                        91680000
         DC    4F'0'                                                    91760000
ECB      DS    F                                                        91840000
INDEX    DC    A(2,22,2,50)                                             91920000
NUMTH    DC    H'1,32,60,91,121,152,182,213,244,274,305,335'            92000000
DAY      DC    D'0'                                                     92080000
DECDT    DS    D                                                        92160000
DATE     DS    CL7                                                      92240000
         DC    C'/'                                                     92320000
SUPLOC   DC    F'0'                                                     92720000
CVDTEM   DS    D                                                        92880000
FINALMR  DS    A                   MR FOR SVC YYQZ USE                  92960000
ITBREGS  DS    7A                  INITIAL REGS FOR ITB1                93040000
         DS    X                                                        93120000
BUCK3    DS    AL3                                                      93200000
CDCBXLE  DC    A(CDCL,LIBPZ,LIBPARS,IM)                                 93280000
ADPAR    EQU   CDCBXLE+8                                                93360000
CYLTEMP  DC    F'0'                                                     93440000
RD1TKW   CCW   X'07',CCHH-2,X'40',6                                     93520000
         CCW   X'31',CCHH,X'40',5                                       93600000
         CCW   X'08',*-8,0,0                                            93680000
RDCCW    CCW   X'06',IM,0,0                                             93760000
         DC    F'0'                                                     93840000
CCHH     DC    F'0'                                                     93920000
         DC    X'01'               RECORD NUMBER                        94000000
INITIM   DC    F'0'                                                     94400000
TEM4     DC    4F'0'                                                    94480000
RMSG     DC    C'APL HAS'                                               94560000
DSLOTS   DC    CL2' '                                                   94640000
         DC    C' SLOTS, '                                              94720000
DFBC     DC    CL4'    '                                                94800000
         DC   C' BUFFERS',X'FF'                                     K04 94880000
ALLOFF   DC    X'00'                                                    94960000
*        EXTERNAL ADDRESS LIST FOR SUPINI                               95040000
*        THESE ADDRESSES ARE PASSED FROM THE MOTHER TASK                95440000
*                                                                       95600000
*                                                                       95680000
*                                                                       95760000
LIST     DS    0A                  START OF LIST                        95840000
ASUPPARS DC    A(SUPPARS)                                               95920000
ACONFINI DC    A(CONFINIT)                                              96000000
ATYI1052 DC    A(TYI1052)                                               96080000
AHISTKIL DC    A(HISTKILL)                                              96160000
ASWAPPAR DC    A(SWAPPARS)                                              96240000
ACONFSWA DC    A(CONFSWAP)                                              96320000
AHTAB    DC    A(HTAB)                                                  96400000
ADIRTAB  DC    A(DIRTAB)                                                96480000
*                                                                       96560000
*                                                                       96640000
         ENTRY ASWAPPAR                                            3043 96800000
ALIBPZ   DS    A                                                        96880000
ALIBPARS DS    A                                                        96960000
AAPLSDCB DS    A                                                        97040000
AZSYMDAT DS    A                                                        97120000
APCSUB   DS    A                                                        97200000
MOTHER   DS    A                                                        97280000
ASVOLDPS DS    A                                                        97360000
ASVINT   DS    A                                                        97440000
LISTLENG EQU   *-LIST              END OF LIST                          97520000
*                                                                       97600000
*        ADDRESSES FILLED IN BY SUPINI FROM SUPPARS                     97680000
ACURRENT DS    A                                                        97760000
AWSLEN   DS    A                                                        97840000
AMANHASH DS    A                                                        97920000
*                                                                       98000000
*        ENTRY POINTS FOR OPLIB,NOPEN,DSKFMT ETC.                       98080000
         ENTRY AAPLSDCB,ALIBPARS,ALIBPZ,ADIRTAB,AWSLEN,AMANHASH         98160000
*                                                                       98240000
*        THE SYMBOLS ARE DEFINED TO ENSURE NO ASSEMBLY ERRORS UNDER OS  98320000
SUPPARS  EQU   0                                                        98400000
CONFINIT EQU   0                                                        98480000
TYI1052  EQU   0                                                        98560000
HISTKILL EQU   0                                                        98640000
SWAPPARS EQU   0                                                        98720000
CONFSWAP EQU   0                                                        98800000
HTAB     EQU   0                                                        98880000
DIRTAB   EQU   0                                                        98960000
APLSUP   EQU   0                                                        99040000
LIBPZ    EQU   0                                                        99120000
LIBPARS  EQU   0                                                        99200000
         LTORG                                                          99360000
         COPY  CDCPARS                                                  99440000
         END   STAREX                                                   99520000
./  ADD    NAME=APLSSLCT
SLCT     TITLE 'C O M P R E S S I O N  ,  E X P A N S I O N   05/11/70' 00150000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00300000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00450000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00600000
         PRINT OFF       APLDEFN, ZSYMBOLS                              00900000
SELECT   CSECT                                                          01050000
         COPY  APLDEFN                                                  01200000
         COPY  ZSYMBOLS                                                 01350000
         PRINT ON,NOGEN                                                 01500000
         COPY  OPSECT                                                   01650000
         TITLE 'C O M P R E S S I O N  ,  E X P A N S I O N   05/11/70' 01800000
SELECT   CSECT                                                          01950000
*                                                                       02100000
*        SELECT EQUATES.                                                02250000
*                                                                       02400000
         SPACE                                                          02550000
BLNKRZ   EQU   DBISAVE             EXPANSION FILL CHARACTER             02700000
DEXTN    EQU   RSAVE               FLOATING EXTENSION                   02850000
ELIDED   EQU   BLOWN               INDEX ELIDED INDICATOR               03000000
EXPZERO  EQU   LOP                 INSERTING ZEROS FLAG                 03150000
EXTN     EQU   XTNSHN              FIXED EXTENSION                      03300000
INNERDF  EQU   HOLDRITE            INNER LOOP DIFFERENCE                03450000
LHINDEX  EQU   LINDX               LEFT FETCH INDEX                     03600000
LINCR    EQU   BINOSAVE                                                 03750000
LINKRES  EQU   SAVER               SAVE LINKREG OVER CALLS              03900000
LHONES   EQU   FACTSAVE            +/LEFT OPERAND                       04050000
LOPRND   EQU   SAVEMALL            LEFT OPERAND FROM STACK              04200000
OUTERDF  EQU   FTEMP               OUTER LOOP INCREMENT                 04350000
PRODLEFT EQU   DBINSAVE            X/(DROP -1)/RHO RIGHT                04500000
PRODRITE EQU   FBINSAVE            X/(OMEGA (RHO RHO RH)-I+1)/RHO RH    04650000
RESBASE  EQU   RESORG              RESULT DATA ORIGIN                   04800000
RESINDEX EQU   RESINDX             RESULT STORE INDEX                   04950000
RESRHOS  EQU   BSIGN               (RHO RESULT) SUB INDEX               05100000
RESXRHO  EQU   RXRHO               X/RHO RESULT                         05250000
RFROUT   EQU   STOP                RIGHT FETCH ROUTINE ADDRESS          05400000
RHINDEX  EQU   RINDX               RIGHT FETCH INDEX                    05550000
RHOSUBX  EQU   BINSAVE             (RHO RIGHT) SUB INDEX                05700000
RINNERDF EQU   RESSIGN             RESULT INNER DIFFERENCE              05850000
ROPRND   EQU   SAVEMALL+12         RIGHT OPERAND FROM STACK             06000000
ROUTERDF EQU   REGSAV              RESULT OUTER DIFFERENCE              06150000
TRIPLET  EQU   SAVEMALL            EXPRESSION FROM STACK                06300000
WHICH    EQU   FCHSCLR             0 - COMPRESSION, 1 - EXPANSION       06450000
         EJECT                                                          06600000
         EXTRN ERROR                                                    06750000
         EXTRN FETCH                                                    06900000
         EXTRN FETCHINT                                                 07050000
         EXTRN MKGARB                                                   07200000
         EXTRN OPCXRHO                                                  07350000
         EXTRN OPSPACE                                                  07500000
         EXTRN STORE                                                    07650000
         SPACE                                                          07800000
         PROLOG OPSECT,NDOPSECT                                         07950000
         SPACE                                                          08100000
         MVC   INCR(4),=F'16'      SET INCR FOR REFETCH IN OPSPACE      08250000
         L     SVIR,SVI            FIRST, FIND STACK POINTER            08400000
         LA    SVIR,M(SVIR)        MAKE IT ABSOLUTE                     08550000
         LM    1,4,4(SVIR)         PICK UP TRIPLET                      08700000
         L     SVIR,SVI            GET RELATIVE SVI AGAIN               08850000
         STM   1,4,TRIPLET         SAVE THE TRIPLET                     09000000
         MVI   WHICH,0             SET INDICATOR TO COMPRESSION         09150000
         CLI   TRIPLET+7,1+2*ZSLASH                                     09300000
         BE    ISCOM               DETERMINE COMPRESSION VS EXPANSION   09450000
         CLI   TRIPLET+7,1+2*ZCOLSLSH                                   09600000
         BE    ISCOM               POSSIBLY COLUMN COMPRESSION          09750000
         MVI   WHICH,1             OTHERWISE, SET INDICATOR TO EXPANSIO 09900000
ISCOM    EQU   *                                                        10050000
         SPACE                                                          10200000
*                                                                       10350000
*        NOW, GET THE INDEX.                                            10500000
*                                                                       10650000
         MVI   ELIDED,0         INITIALIZE INDICATOR TO INDEX           10800000
         LTR   3,3              SEE IF THERE REALLY IS ONE              10950000
         BZ    ELISION          BRANCH IF NOT                           11100000
         LH    2,MLSCT(3)       PICK UP COUNT OF ELEMENTS               11400000
         L     3,MLSORG(3)      OTHERWISE, PICK UP FIRST LIST EL        11550000
         BCT   2,SYNTER            ERROR IF MORE THAN ONE ELEMENT   G01 11700000
         SPACE                                                          11850000
         LTR   3,3              SEE IF IT'S TEMPORARY                   12000000
         BNM   LSPTR            BRANCH IF NOT                           12150000
         L     3,M(3)           GET M-ENTRY POINTER                     12300000
LSPTR    N     3,FRACMASK       REMOVE HI-ORDER GARBAGE                 12450000
         BZ    VALERR              MIGHT BE UNDEFINED                   12600000
         ST    3,INDBASE        AND SAVE THE INDEX                      12750000
         LH    2,MRANK(3)       PICK UP RANK                            12900000
         ST    2,INDRANK        OTHERWISE SAVE IT                       13050000
         LTR   2,2              SEE IF IT'S ZERO                        13200000
         BZ    GETINDEX         BRANCH IF SO                            13350000
         L     10,=A(OPCXRHO)   ENTER COMMON CXRHO SUBROUTINE           13500000
         BALR  LKR,10                                                   13650000
         ST    1,INDXRHO        STORE THE RESULT                        13800000
         C     1,COM1           SEE IF THERE IS ONE ELEMENT             13950000
         BNE   SYNTER              BRANCH IF YES                    G01 14100000
         L     3,INDBASE           PICK UP BASE AGAIN               G01 14250000
GETINDEX LR    4,3              MOVE IT TO R4                           14400000
         SR    3,3              CLEAR R3                                14550000
         IC    3,MTYPE(4)       PICK UP TYPE                            14700000
         SR    2,2              SET FOR FIRST ELEMENT                   14850000
         A     4,INDRANK        ADD IN RANK                             15000000
         LA    4,MRHO-M(4)      AND HEADER SPACE                        15150000
         ICALL FETCHINT         AND GET THE INDEX                       15300000
         S     0,IORIGIN        FOLLOW INDEX ORIGIN                     15450000
ELBACK   ST    0,INDEX          AND SAVE IT                             15600000
*                                                                       15750000
*          NOW, CHECK OUT LEFT OPERAND                                  15900000
*                                                                       16050000
         SPACE                                                          16200000
         L     3,LOPRND            PICK UP STACK ENTRY                  16350000
         LTR   3,3                 SEE IF IT IS                         16500000
         BNM   GOTLEFT                                                  16650000
         L     3,M(3)              OTHERWISE, GO INDIRECT               16800000
GOTLEFT  N     3,FRACMASK          REMOVE HI-ORDER BYTE                 16950000
         BZ    VALERR              MIGHT BE UNDEFINED                   17100000
         LA    4,MLIST(3)          CHECK THE LISTBIT                    17250000
         TM    0(4),MLSTBIT        SHOULD NOT BE ON                     17400000
         BNZ   SYNTER              BRANCH IF SO                     G01 17550000
         ST    3,LHBASE            SAVE THE BASE                        17700000
         LH    2,MRANK(3)          PICK UP THE RANK                     17850000
         ST    2,LHRANK            SAVE IT                              18000000
         SR    4,4                                                      18150000
         IC    4,MTYPE(3)          PICK UP THE TYPE                     18300000
         ST    4,LHTYPE            AND SAVE IT                          18450000
         SPACE                                                          18600000
         L     10,=A(OPCXRHO)      GET ENTRY TO COMMON X/RHO ROUTINE    18750000
         BALR  LKR,10                                                   18900000
         ST    1,LHXRHO            AND SAVE THE RESULT                  19050000
         L     2,LHRANK            NOW, DO SOME CHECKING                19200000
         C     2,COM4              LH SIDE MUST BE A VECTOR             19350000
         BNH   LHRANKOK            LET SCALARS SNEAK THROUGH            19500000
         C     1,COM1              OTHERWISE, CHECK X/RHO               19650000
         BE    LHRANKOK            BRANCH IF ONE                        19800000
RANKEROR LA    1,ERANK             OTHERWISE,                           19950000
         ICALL ERROR               RANK ERROR                           20100000
         SPACE                                                          20250000
LHRANKOK L     4,LHBASE            CALCULATE +/LEFT OPERAND             20400000
         A     4,LHRANK                                                 20550000
         LA    4,MRHO-M(4)                                              20700000
         L     3,LHTYPE                                                 20850000
         IC    3,CTOI-1(3)         GET FETCH CONVERSION TYPE            21000000
         ST    3,LCFTYPE           STORE THE TYPE                       21150000
         SR    2,2                 SET UP FOR FETCH                     21300000
         SR    5,5                 INITIALIZE SUM                       21450000
         L     8,LHXRHO            LOOP COUNTER                         21600000
         SPACE                                                          21750000
         LTR   8,8                 SEE IF LH IS EMPTY                   21900000
         BNZ   PREDUCE             BRANCH IF NOT                        22050000
         ST    8,LHONES            OTHERWISE, SET +/LEFT TO 0           22200000
         B     GETRIGHT            GO GET RH OPERAND                    22350000
         SPACE                                                          22500000
PREDUCE  ICALL FETCH               FETCH A LEFT                         22650000
         LA    2,1(2)              BUMP INDEX                           22800000
         CL    0,COM1              CHECK AGAINST 1                      22950000
         BH    RANGEROR            BRANCH OUT IF GREATER                23100000
         AR    5,0                 OTHERWISE, ADD IT IN                 23250000
         QUEND                                                          23400000
         BCT   8,PREDUCE           AND LOOP                             23550000
         ST    5,LHONES            SAVE RESULT                          23700000
         SPACE                                                          23850000
GETRIGHT L     3,ROPRND            NOW, GET SOME RH STUFF               24000000
         MVI   RHSCALAR,0          SET RH TO NOT SCALAR                 24150000
         LTR   3,3                 SEE IF IT REALLY IS                  24300000
         BNM   GOTRIGHT                                                 24450000
         L     3,M(3)              OTHERWISE, GO INDIRECT               24600000
GOTRIGHT N     3,FRACMASK          GET RID OF HI-ORDER BYTE             24750000
         BZ    VALERR              MIGHT BE UNDEFINED                   24900000
         LA    4,MLIST(3)          SEE IF IT'S A LIST                   25050000
         TM    0(4),MLSTBIT        IT SHOULDN'T BE                      25200000
         BNZ   SYNTER              BRANCH IF SO                     G01 25350000
NORLBT   ST    3,RHBASE            OTHERWISE, SAVE BASE                 25500000
         LH    2,MRANK(3)          PICK UP THE RANK                     25650000
         ST    2,RHRANK            AND SAVE IT                          25800000
         SR    4,4                                                      25950000
         IC    4,MTYPE(3)          PICK UP THE TYPE                     26100000
         ST    4,RCFTYPE           SAVE IT                              26250000
         L     10,=A(OPCXRHO)      GET EMTRY TO COMMON X/RHO ROUTINE    26400000
         BALR  LKR,10              AND CALL IT                          26550000
         ST    1,RHXRHO            SAVE RESULT                          26700000
         L     4,RHBASE            PICK UP RH BASE AGAIN                26850000
         L     3,RHRANK            SEE IF RH IS SCALAR                  27000000
         CL    1,COM1                                                   27150000
         BNE   CHEKINDX            BRANCH IF NOT ONE COMPONENT          27300000
         MVI   RHSCALAR,1          OTHERWISE, SET INDICATOR             27450000
         LTR   3,3                                                      27600000
         BNZ   CHEKINDX                                                 27750000
         B     SCLRIN              JUMP INTO INDEX ROUTINE              27900000
         SPACE                                                          28050000
CHEKINDX L     2,INDEX             PICK UP THE INDEX                    28200000
         SLA   2,2                 MULTIPLY IT BY 4                     28350000
         BC    5,ELIDCHEK          BRANCH ON OVERFLOW OR NEGATIVE       28500000
         CR    2,3                 COMPARE IT TO RANK                   28650000
         BNL   ELIDCHEK                                                 28800000
TWAS     AR    2,4                 OTHERWISE,                           28950000
         L     2,MRHO(2)           PICK UP APPROPIATE EL OF RANK VECTOR 29100000
         ST    2,RHOSUBX           AND SAVE IT                          29250000
         TM    RHSCALAR,1                                               29400000
         BZ    CONFORM                                                  29550000
SCLRIN   TM    WHICH,1             TEST OPERATOR                        29700000
         BZ    ITSCOMP             BRANCH IF COMPRESSION                29850000
         MVC   RHOSUBX(4),LHONES                                        30000000
         MVC   RESRHOS(4),LHXRHO                                        30150000
         B     CONFORM                                                  30300000
ITSCOMP  MVC   RHOSUBX(4),LHXRHO                                        30450000
         MVC   RESRHOS(4),LHONES                                        30600000
         B     CONFORM                                                  30750000
         SPACE                                                          30900000
*                                                                       31050000
*        END UP HERE ON ELIDED INDEX.                                   31200000
*                                                                       31350000
         SPACE                                                          31500000
ELISION  L     0,ABLES             ABLES IS X'2AAAAAAA'                 31650000
         MVI   ELIDED,1                                                 31800000
         B     ELBACK                                                   31950000
         SPACE                                                          32100000
ELIDCHEK TM    ELIDED,1            SEE IF INDEX WAS ELIDED              32250000
         BZ    INDEXER             BRANCH IF NOT                        32400000
         SR    2,2                 ASSUME COLUMN OPERATION              32550000
         CLI   TRIPLET+7,1+2*ZBSLASH                                    32700000
         BH    ELCH2               IT IS. TAKE FIRST COORDINATE.        32850000
         LR    2,3                 OTHERWISE, SET INDEX TO RHO RHO RH   33000000
         S     2,COM4                                                   33150000
ELCH2    LR    1,2                                                      33300000
         SRL   1,2                                                      33450000
         ST    1,INDEX                                                  33600000
         B     TWAS                                                     33750000
         SPACE                                                          33900000
         EJECT                                                          34050000
*                                                                       34200000
*        CONFORMABILITY CHECK.                                          34350000
*                                                                       34500000
         SPACE                                                          34650000
CONFORM  LA    3,1                 INITIALIZE FETCH INCREMENT           34800000
         ST    3,LINCR             FOR USE DURING COMPRESSION LOOPS     34950000
         TM    WHICH,1             SEE IF THIS IS EXPANSION             35100000
         BO    EXPCNFM             BRANCH IF SO                         35250000
         L     1,LHXRHO            SEE IF LEFT IS ONE-COMPONENT         35400000
         LR    2,1                                                      35550000
         BCT   2,COMPCNFM          BRANCH IF NOT                        35700000
         SPACE                                                          35850000
*        LH OPERAND ONE COMPONENT.                                      36000000
*        LEFT OPERAND SCALAR EXTENSION IN COMPRESSION ONLY              36150000
         SPACE                                                          36300000
         MVI   LINCR+3,0           RESET LEFT FETCH INCREMENT           36450000
         L     1,RHOSUBX           PICK UP SELECTEE DIMENSION           36600000
         ST    1,LHXRHO            EXTENDED LEFT LENGTH                 36750000
         ST    1,RESRHOS           SAVE AS RESULT DIMENSION             36900000
         L     2,LHONES            GET +/LEFT OPERAND                   37050000
         LTR   2,2                 ZERO OR ONE                          37200000
         BNZ   XTCOMP              BRANCH IF ONE                        37350000
         ST    2,RESRHOS           OTHERWISE, RESULT WILL BE EMPTY      37500000
         B     CALCSPAC                                                 37650000
XTCOMP   ST    1,LHONES            STORE EXTENDED +/LEFT OPERAND        37800000
         B     CALCSPAC                                                 37950000
         SPACE                                                          38100000
*        LH OPERAND IS A VECTOR.                                        38250000
         SPACE                                                          38400000
COMPCNFM L     2,RHOSUBX           GET SELECTEE DIMENSION               38550000
         CR    1,2                 COMPARE TO LEFT LENGTH               38700000
         BNE   LENGTHER            LENGTH ERROR IF UNEQUAL              38850000
         B     CALCSPAC            OTHERWISE, GO CALCULATE SPACE        39000000
         SPACE                                                          39150000
EXPCNFM  L     1,RHOSUBX           PICK UP SELECTEE DIMENSION           39300000
         C     1,LHONES            COMPARE TO +/LEFT                    39450000
         BNE   LENGTHER            LENGTH ERROR IF UNEQUAL              39600000
FILCHAR  SR    1,1                 FIX UP INSERT CHARACTER              39750000
         ST    1,BLNKRZ                                                 39900000
         L     3,RCFTYPE           NOW, LOOK AT RH TYPE                 40050000
         C     3,COM4              SEE IF IT'S CHARACTER                40200000
         BL    CALCSPAC            BRANCH IF NOT                        40350000
         LA    1,ZBLANK            CHANGE INSERT TO BLANK               40500000
         STC   1,BLNKRZ                                                 40650000
         EJECT                                                          40800000
*                                                                       40950000
*        CALCULATE, AND GET, SPACE.                                     41100000
*                                                                       41250000
         SPACE                                                          41400000
CALCSPAC ON    XDZ,ZERODEV         SET UP ZERO DIVIDE INTERUPT          41550000
         TM    RHSCALAR,1          SEE IF RH IS SCALAR                  41700000
         BZ    NXTSPAC             BRANCH IF NOT                        41850000
         L     1,LHONES            X/RHO RESULT IS +/LEFT               42000000
         TM    WHICH,1             IF WE'RE COMPRESSING                 42150000
         BZ    RBYVIN              BRANCH IF SO                         42300000
         L     1,LHXRHO            OTHERWISE, IT'S X/RHO LEFT           42450000
         B     RBYVIN                                                   42600000
         SPACE                                                          42750000
NXTSPAC  L     1,RHXRHO            PICK UP X/RHO RHS                    42900000
         L     2,LHONES            PICK UP +/LEFT                       43050000
         TM    WHICH,1             SEE IF WE'RE COMPRESSING             43200000
         BZ    COMSPAC             BRANCH IF SO                         43350000
         L     2,LHXRHO            OTHERWISE, PICK UP LEFT LENGTH       43500000
COMSPAC  ST    2,RESRHOS           MULTIPLY BY THIS                     43650000
         MR    0,2                                                      43800000
         D     0,RHOSUBX           DIVIDE BY SELECTEE DIMENSION         43950000
         B     RBYVIN                                                   44100000
ZERODEV  SR   1,1                 WE GET HERE ON A ZERO DIVIDE          44250000
         TM   WHICH,1             SEE IF WE'RE COMPRESSING              44400000
         BZ    RBYVIN              BRANCH IF SO                         44550000
*        EXPANSION OF AN EMPTY ARRAY, STORE NEW RANK VECTOR ELEMENT,    44700000
*        RECOMPUTE X/RHO RHS, THEN RETURN RHS RANK ELEMENT TO ZERO      44850000
         L     1,LHXRHO            OTHERWISE, PICK UP LEFT LENGTH       45000000
         L     9,INDEX             FIND THE RANK ELEMENT                45150000
         SLL   9,2                                                      45300000
         L     8,RHBASE            PICK ADDRESS OF RH M ENTRY           45450000
         LA    8,MRHO(8)           DISPLACED TO RANK VECTOR             45600000
         ST    1,0(8,9)            STORE NEW ELEMENT                    45750000
         L     3,RHBASE            NOW, COMPUTE NEW X/RHO               45900000
         L     2,RHRANK                                                 46050000
         L     10,=A(OPCXRHO)      TAKE OFF TO XRHO ROUTINE             46200000
         BALR  LKR,10                                                   46350000
         SR    2,2                 RETURN RANK VECTOR OF RHS TO         46500000
         ST    2,0(8,9)            ORIGINAL FORM                        46650000
         SPACE                                                          46800000
*        NOW HAVE X/RHO RESULT IN R1.                                   46950000
         SPACE                                                          47100000
RBYVIN   ST    1,RESXRHO           SAVE IT                              47250000
         L     2,RHRANK            PICK UP THE RANK                     47400000
         LTR   2,2                 SEE IF IT'S SCALAR                   47550000
         BNZ   *+8                 BRANCH IF NOT                        47700000
         LA    2,4                 OTHERWISE, MAKE IT VECTOR            47850000
         L     3,RCFTYPE           AND THE TYPE                         48000000
         L     10,=A(OPSPACE)      GET ENTRY TO COMMON GETSPACE ROUTINE 48150000
         BALR  LKR,10              AND CALL IT                          48300000
         ST    1,RESBASE           AND SAVE RESULT M-POINTER            48450000
         ON    XDZ                 REVERT ZERO-DIVIDE CONDITION         48600000
*                                                                       48750000
*                                                                       48900000
*        SET UP RESULT HEADING.                                         49050000
*                                                                       49200000
         LA    1,FECHRITE          SET UP RIGHT FETCH ROUTINE           49350000
         TM    RHSCALAR,1          SEE IF RIGHT EXTENDS                 49500000
         BZ    *+8                 BRANCH IF NOT                        49650000
         LA    1,RHXTND            OTHERWISE, SET UP EXTENSION          49800000
         ST    1,RFROUT            AND SAVE ADDRESS                     49950000
         SPACE                                                          50100000
         L     1,RESBASE                                                50250000
         L     2,RHRANK            RNAK                                 50400000
         ST    2,MTYPE(1)                                               50700000
         IC    2,RCFTYPE+3         TYPE                                 50850000
         STC   2,MTYPE(1)                                               51000000
         LA    1,MRHO(1)           RANK VECTOR                          51150000
         L     2,RHBASE                                                 51300000
         LA    2,MRHO(2)                                                51450000
         L     3,RHRANK                                                 51600000
         LTR   3,3                 SEE IF RIGHT IS SCALAR               51750000
         BZ    SCLSETUP            BRANCH IF SO                         51900000
         BCTR  3,0                                                      52050000
         EX    3,MOVRANK           MOVED IN                             52200000
         L     3,INDEX             PICK UP INDEX                        52350000
         L     4,RESRHOS           AND NEW DIMENSION                    52500000
         SLL   3,2                 X 4                                  52650000
         ST    4,0(1,3)            STORED                               52800000
         B     VSETUP                                                   52950000
         SPACE                                                          53100000
SCLSETUP LA    3,4                 DECREMENT RESULT POINTER BY 4        53250000
         SR    1,3                                                      53400000
         STH   3,2(1)              SET RANK OF RESULT TO VECTOR         53700000
         L     3,RESXRHO           PICK UP LENGTH                       53850000
         ST    3,4(1)              AND STORE IT IN RANK VECTOR          54000000
         LA    5,1                 AND DO SOME OF THEM                  54150000
         ST    5,PRODLEFT                                               54300000
         B     RITEDONE            AND JUMP INTO THEM                   54450000
         SPACE                                                          54600000
         EJECT                                                          54750000
*                                                                       54900000
*        NOW, SET UP AND COMPUTE.                                       55050000
*                                                                       55200000
         SPACE                                                          55350000
VSETUP   EQU   *                                                        55500000
         L     8,RHBASE            PICK UP RH POINTER                   55650000
         LA    8,MRHO-M(8)         POINT AT FIRST RANK ELEMENT          55800000
         L     7,INDEX             PICK UP THE INDEX                    55950000
         SLL   7,2                 X 4                                  56100000
         AR    7,8                 + BASE OF RANK VECTOR                56250000
         L     6,RHRANK            PICK UP RANK                         56400000
         AR    6,8                 FOR STOPPING                         56550000
         LA    5,1                 PRODUCT                              56700000
LEFTLOOP CR    8,7                 SEE IF WE'RE DONE                    56850000
         BNL   LEFTDONE            BRANCH IF SO                         57000000
         M     4,M(8)              OTHERWISE, MULTIPLY                  57150000
         LTR   4,4                                                  A01 57300000
         BNZ   WSFULL                                               A01 57450000
         LA    8,4(8)              BUMP POINTER                         57600000
         B     LEFTLOOP            AND LOOP                             57750000
LEFTDONE ST    5,PRODLEFT                                               57900000
         LA    8,4(8)              SKIP INDEXED ELEMENT                 58050000
         LA    5,1                 RE-INITIALIZE PRODUCT                58200000
RITELOOP CR    8,6                 SEE IF WE'RE DONE                    58350000
         BNL   RITEDONE                                                 58500000
         M     4,M(8)              OTHERWISE, MULTIPLY                  58650000
         LTR   4,4                                                  A01 58800000
         BNZ   WSFULL                                               A01 58950000
         LA    8,4(8)              BUMP POINTER                         59100000
         B     RITELOOP            ASN LOOP                             59250000
RITEDONE ST    5,PRODRITE                                               59400000
         S     5,RHXRHO            SUBTRACT RIGHT LENGTH                59550000
         ST    5,OUTERDF           FROM RIGHT PRODUCT                   59700000
         L     3,RHOSUBX           PICK UP SELECTEE DIMENSION           59850000
         BCTR  3,0                 SUBTRACT 1                           60000000
         M     2,PRODRITE          MULTIPLY BY RIGHT PRODUCT            60150000
         LTR   2,2                                                  A01 60300000
         BC    0,WSFULL            TEMPORARY BYPASS                 A01 60450000
         ST    3,INNERDF                                                60600000
         L     3,PRODRITE          RIGHT LENGTH                         60750000
         S     3,RESXRHO           - RESULT LENGTH                      60900000
         ST    3,ROUTERDF                                               61050000
         L     3,RESRHOS                                                61200000
         BCTR  3,0                                                      61350000
         M     2,PRODRITE                                               61500000
         ST    3,RINNERDF                                               61650000
         L     2,PRODLEFT                                               61800000
         LTR   2,2                                                      61950000
         BNZ   *+8                                                      62100000
         MVI   PRODLEFT+3,1                                             62250000
         L     2,PRODRITE                                               62400000
         LTR   2,2                                                      62550000
         BNZ   *+8                                                      62700000
         MVI   PRODRITE+3,1                                             62850000
         L     8,LHXRHO            PICK UP INNER LENGTH                 63000000
         SPACE                                                          63150000
         SR    2,2                 INITIALIZE FETCH INDICES             63300000
         ST    2,LHINDEX                                                63450000
         ST    2,RHINDEX                                                63600000
         ST    2,RESINDEX                                               63750000
         L     2,RCFTYPE           RESULT STORE TYPE                    63900000
         ST    2,RESTYPE                                                64050000
         L     2,RHRANK                                                 64200000
         LTR   2,2                                                      64350000
         BNZ   *+8                                                      64500000
         LA    2,4                                                      64650000
         A     2,RESBASE           RESULT BASE                          64800000
         LA    2,MRHO-M(2)                                              64950000
         ST    2,RESBASE                                                65100000
         SPACE                                                          65250000
*                                                                       65400000
*        GARBAGE IS MARKED HERE.                                        65550000
*                                                                       65700000
         SPACE                                                          65850000
         L     SVIR,SVI            PICK UP SVI AGAIN                    66000000
         L     1,M+16(SVIR)        PICK UP INDEX                        66150000
         ICALL MKGARB              MARK LIST GARBAGE                    66300000
         L     1,M+20(SVIR)        PICK UP RH POINTER                   66450000
         ICALL MKGARB              MARK GARBAGE IF TEMP                 66600000
         L     1,RHBASE                                                 66750000
         A     1,RHRANK            SET BASE ADDRESS                     66900000
         LA    1,MRHO-M(1)         TO FIRST ELEMENT                     67050000
         ST    1,RHORG             POINT AT DATA                        67200000
         L     1,M+8(SVIR)         SAME PROCEDURE FOR LEFT ARG          67350000
         ICALL MKGARB                                                   67500000
         L     1,LHBASE                                                 67650000
         A     1,LHRANK                                                 67800000
         LA    1,MRHO-M(1)                                              67950000
         ST    1,LHORG             POINT AT DATA                        68100000
         SPACE                                                          68250000
*                                                                       68400000
*        WE'RE ALL SET.                                                 68550000
*                                                                       68700000
         EJECT                                                          68850000
*                                                                       69000000
*        COMPRESSION, EXPANSION, SOOPER LOOP                            69150000
*                                                                       69300000
         SPACE                                                          69450000
         LTR   8,8                                                      69600000
         BZ    CLEANUP             BRANCH IF SO                         69750000
         L     5,RESXRHO           X / RESULT                           69900000
         LTR   5,5                 SEE IF RESULT IS EMPTY               70050000
         BZ    CLEANUP             BRANCH IF SO                         70200000
         L     7,RHXRHO            SEE IF RIGHT WAS EMPTY               70350000
         LTR   7,7                                                      70500000
         BNZ   OUTER                                                    70650000
         TM    WHICH,1                                                  70800000
         BZ    CLEANUP                                                  70950000
*        EXPANSION OF EMPTY ARRAY.                                      71100000
         LA    6,1                 MIDDLE LOOP COUNT                    71250000
         LA    8,1                 OUTER LOOP COUNT                     71400000
         LA    7,SKIPRITE          BRANCH ADDRESS AT 'INNER'            71550000
         B     SKIPRITE            ENTER INNER LOOP                     71700000
         SPACE                                                          71850000
*        OUTER LOOP.                                                    72000000
         SPACE                                                          72150000
OUTER    LM    2,4,LHFETCH         PICK UP LEFT                         72300000
         ICALL FETCH                                                    72450000
         A     2,LINCR                                                  72600000
         ST    2,LHINDEX                                                72750000
         MVI   EXPZERO,0                                                72900000
         BCT   0,GOTAZERO          BRANCH IF IT'S A ZERO                73050000
GOTAONE  L     7,RFROUT            ADDRESS OF RIGHT FETCH               73200000
         B     SECOND              BRANCH TO START OF SECOND LOOP       73350000
         SPACE                                                          73500000
GOTAZERO TM    WHICH,1             SEE IF WE'RE COMPRESSING             73650000
         BZ    SKIP                BRANCH IF SO                         73800000
         LA    7,SKIPRITE          ADDRESS TO SKIP FETCH                73950000
         MVI   EXPZERO,1                                                74100000
         SPACE                                                          74250000
*        MIDDLE LOOP.                                                   74400000
         SPACE                                                          74550000
SECOND   L     6,PRODLEFT          COUNT FOR MIDDLE LOOP                74700000
MIDDLE   L     5,PRODRITE          COUNT FOR INNER LOOP                 74850000
         SPACE                                                          75000000
*        INNER LOOP.                                                    75150000
         SPACE                                                          75300000
INNER    BALR  LKR,7                                                    75450000
         LA    2,1(2)              BUMP INDEX BY ONE                    75600000
         ST    2,RHINDEX                                                75750000
         B     STORIT              GO AND STORE IT                      75900000
SKIPRITE SR    1,1                 SET UP EXPANSION STORE               76050000
         L     0,BLNKRZ            PICK UP ZERO OR BLANK                76200000
         SDR   0,0                                                      76350000
STORIT   LM    2,4,RESTORE         STORE A RESULT ELEMENT               76500000
         ICALL STORE                                                    76650000
         LA    2,1(2)              INCR STORE INDEX BY 1                76800000
         ST    2,RESINDEX                                               76950000
         QUEND                                                          77100000
         BCT   5,INNER             END OF INNER LOOP                    77250000
         SPACE                                                          77400000
MIDEND   A     2,RINNERDF          ADD IN LOOP INCR                     77550000
         ST    2,RESINDEX                                               77700000
         TM    EXPZERO,1                                                77850000
         BO    NOINCR                                                   78000000
         L     2,RHINDEX                                                78150000
         A     2,INNERDF                                                78300000
         ST    2,RHINDEX                                                78450000
NOINCR   QUEND                                                          78600000
         BCT   6,MIDDLE            END OF MIDDLE LOOP                   78750000
         SPACE                                                          78900000
         TM    EXPZERO,1                                                79050000
         BO    DNTOUCH                                                  79200000
         A     2,OUTERDF           ADD OUTER LOOP INCRS                 79350000
         ST    2,RHINDEX                                                79500000
DNTOUCH  L     2,RESINDEX                                               79650000
         A     2,ROUTERDF                                               79800000
         ST    2,RESINDEX                                               79950000
OUTEREND QUEND                                                          80100000
         BCT   8,OUTER             END OF OUTER LOOP                    80250000
         B     CLEANUP             GO CLEAN UP                          80400000
         SPACE                                                          80550000
SKIP     L     2,RHINDEX                                                80700000
         A     2,PRODRITE                                               80850000
         ST    2,RHINDEX                                                81000000
         B     OUTEREND                                                 81150000
         SPACE                                                          81300000
*                                                                       81450000
*        CLEAN UP.                                                      81600000
*                                                                       81750000
         SPACE                                                          81900000
CLEANUP  EQU   *                                                        82050000
         L     SVIR,SVI            PICK UP STACK POINTER                82200000
         L     7,M+4(SVIR)         PICK UP RESULT STACK EL              82350000
         O     7,CLASSC            PUT IN CLASS = TEMP                  82500000
         LA    SVIR,16(SVIR)       BUMP UP STACK POINTER                82650000
         ST    SVIR,SVI            STORE IT                             82800000
         LA    SVIR,4(SVIR)        BUMP IT AGAIN                        82950000
         ST    SVIR,MHEAD(7)       PUT INTO RESULT HEAD                 83100000
         ST    7,M(SVIR)           ENTRY IN STACK                       83250000
         IRETURN                                                        83400000
         EJECT                                                          83550000
*                                                                       83700000
*        SET UP TO SPECIFY RESULT BY RHX                                83850000
*                                                                       84000000
         SPACE                                                          84150000
*                                                                       84300000
*        FETCH ROUTINES.                                                84450000
*                                                                       84600000
         SPACE                                                          84750000
         SPACE                                                          84900000
RHXTND   ST    LKR,LINKRES         SAVE LINK                            85050000
         LM    3,4,RHFETCH+4                                            85200000
         SR    2,2                 WANT FIRST ELEMENT                   85350000
         ICALL FETCH                                                    85500000
         ST    0,EXTN                                                   85650000
         STD   0,DEXTN                                                  85800000
         LA    7,PKUPXT                                                 85950000
         ST    7,RFROUT                                                 86100000
         L     LKR,LINKRES                                              86250000
         BR    LKR                                                      86400000
         SPACE                                                          86550000
PKUPXT   L     0,EXTN                                                   86700000
         LD    0,DEXTN                                                  86850000
         BR    LKR                                                      87000000
         SPACE                                                          87150000
FECHRITE ST    LKR,LINKRES                                              87300000
         LM    2,4,RHFETCH                                              87450000
         ICALL FETCH                                                    87600000
         L     LKR,LINKRES                                              87750000
         BR    LKR                                                      87900000
         SPACE                                                          88050000
*                                                                       88200000
*        ERRORS.                                                        88350000
*                                                                       88500000
         SPACE                                                          88650000
RANGEROR LA    1,ERANGE                                                 88800000
         B     ERXIT                                                A01 88950000
         SPACE 1                                                    A01 89100000
WSFULL   LA    1,EMFULL                                             A01 89250000
ERXIT    ICALL ERROR                                                A01 89400000
         SPACE                                                          89550000
LENGTHER LA    1,ELENGTH                                                89700000
         ICALL ERROR                                                    89850000
         SPACE                                                          90000000
INDEXER  LA    1,EINDEX                                                 90150000
         ICALL ERROR                                                    90300000
         SPACE                                                          90450000
VALERR   LA    1,EVALUE            VALUE ERROR DETECTED                 90600000
         ICALL ERROR               SOMEONE DELETED A LOCAL IN SUSPENDED 90750000
         SPACE 1                                                    G01 90900000
SYNTER   LA    1,ESYNTAX                                            G01 91050000
         ICALL ERROR                                                G01 91200000
         TITLE 'CONSTANTS.'                                             91350000
*                                                                       91500000
*        CONSTANTS.                                                     91650000
*                                                                       91800000
         SPACE                                                          91950000
SVIR     EQU   9                                                        92100000
         SPACE                                                          92250000
MOVRANK  MVC   0(0,1),0(2)                                              92400000
COM1     DC    F'1'                                                     92550000
COM4     DC    F'4'                                                     92700000
CLASSC   DC    AL1(CONST,0,0,0)                                         92850000
ABLES    DC    X'2AAAAAAA'                                              93000000
FRACMASK DC    X'00FFFFFF'                                              93150000
CTOI     DC    FL1'5,2,10,11'                                           93300000
         SPACE                                                          93450000
         LTORG                                                          93600000
         END                                                            93750000
./  ADD    NAME=APLSSYNT
SYNT     TITLE 'A P L   S Y N T A X   A N A L Y S I S         05/11/70' 00050000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00100000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00150000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00200000
         MACRO                                                          00250000
&L       PATH  &GRPH,&NG                                                00300000
         AIF   (T'&L EQ 'O').NL                                         00350000
&L       EQU   *-DIAG                                                   00400000
.NL      ANOP                                                           00450000
         DC    AL1(&GRPH(1),&GRPH(2))                                   00500000
         ORG   *+DIIR-DIAG-2                                            00550000
         DC    Y(&GRPH(3)-SYNST1)                                       00600000
         ORG   *+DIAG-DIIR                                              00650000
         AIF   (T'&NG EQ 'O').AUS                                       00700000
         DC    X'FFFF'                                                  00750000
.AUS     MEND                                                           00800000
         MACRO                                                          00850000
&ZQ      SYLC  &Q                                                       00900000
         ORG   SYLCLASS+Z&ZQ*2+1                                        00950000
         DC    AL1(&Q)                                                  01000000
         MEND                                                           01050000
         PRINT NOGEN                                                    01150000
SYNTXX   CSECT                                                          01200000
         COPY  APLDEFN                                                  01250000
         COPY  ZSYMBOLS                                                 01300000
         COPY  PERTERM                                                  01350000
         TITLE 'SYNTAX ANALYSIS AND TRANSITION DIAGRAMS       05/11/70' 01400000
         ENTRY NONSTMTD                                                 01450000
         EXTRN DODOP                                                    01500000
         EXTRN DOMOP                                                    01550000
         EXTRN ERAST                                                    01600000
         EXTRN ERROR                                                    01650000
         EXTRN FETCHINT                                                 01700000
         EXTRN GCOL                                                     01750000
         EXTRN GETSPACE                                                 01800000
         EXTRN GOUT                                                     01850000
         EXTRN INDEX                                                    01900000
         EXTRN LOUT                                                     01950000
         EXTRN LOUTI                                                    02000000
         EXTRN MKGARB                                                   02050000
         EXTRN PLINF                                                    02100000
         EXTRN SELECT                                                   02150000
         EXTRN XRHO                                                     02200000
*                                                                       02250000
SYNTXX   CSECT                                                          02300000
         LA    TLR,16(LR)          PRETEND THAT TYPEIN HAS NO LOCALS    02350000
*                                  SO IT AND SYNT CAN USE OVERLAPPING   02400000
*                                  AREAS.  THE FIRST 4 WORDS CONTAIN    02450000
*                                  THE END OF THE LINKED REGISTER-SAVE  02500000
*                                  LIST, AND MUST NOT BE DISTURBED.     02550000
         PROLOG LOCALS,LEND                                             02600000
         MVI   BRVAL,X'C0'         REALLY OUT-OF-RANGE BRANCH ADDR      02650000
         TM    RUNCTL,RCOLBIT      IF ENTERED BECAUSE WE'RE EXITING     02700000
         BO    IRS2L               FROM A LOCKED FN, REJOIN END-OF-STMT 02750000
*                                  CODE WITH ADDRESSABILITY REESTAB-    02800000
*                                  LISHED.                              02850000
SYNST1   LA    1,STMTSTMT          START SYNTAX ANALYZER OFF AT STMT    02900000
         ST    1,PATH              DIAGRAM                              02950000
         MVI   BAKTOG,0                                                 03000000
         MVI   NEXTOG,1                                                 03050000
         NI    RUNCTL,RCQEBIT      INDICATE NOT BRANCH STATEMENT        03100000
*                                                                       03150000
*        THIS CODE ANALYZES A STATEMENT AND EXECUTES INTERPRETATION     03200000
*        RULES BY COMPARING SUCCESSIVE SYMBOLS IN THE STATEMENT TO      03250000
*        PATHS IN TRANSITION DIAGRAMS STORED AT 'DIAG'.  R3 CONTAINS    03300000
*        A POINTER TO THE RELEVANT PATH IN DIAG.  POINTERS TO PATHS     03350000
*        IN OUTER DIAGRAMS ARE REMEMBERED WHILE TRAVERSING AN INNER     03400000
*        DIAGRAM BY BEING STACKED IN A BYTE-WIDE STACK 'DIAST', INDEXED 03450000
*        BY 'DIASTPTR'.                                                 03500000
*                                                                       03550000
*        WHEN AN INTERPRETATION RULE IS EXECUTED, DIASTPTR POINTS TO    03600000
*        THE FIRST BYTE PAST TOP OF DIAGRAM STACK.                      03650000
*                                                                       03700000
*              REENTRY AFTER EXECUTING INTERPRETATION RULE              03750000
*                                                                       03800000
SYNTX    QUEND                   , ALLOW QUANTUM END                    03850000
         L     3,PATH              RECALL CURRENT PATH                  03900000
         LA    1,DIAG(3)                                                03950000
         CLI   1(1),0              WHERE DOES THIS PATH LEAD --         04000000
         BNE   SYNT07              TO NEXT NODE IN DIAGRAM.             04050000
         L     1,DIASTPTR          OUT OF DIAGRAM.  PICK UP TOP OF DIAG 04100000
         BCTR  1,0                 STACK AND DROP STACK POINTER.        04150000
         ST    1,DIASTPTR                                               04200000
         AR    1,MR                                                     04250000
         OC    BAKTOG,DIAST-M(1)   OR SAVED AND CURRENT BAKTOGS.        04300000
         NI    BAKTOG,1            MASK OUT GARBAGE.                    04350000
         NI    DIAST-M(1),X'FE'    NOW PICK UP OLD PATH, WHICH WE HAVE  04400000
         IC    3,DIAST-M(1)        SUCCESSFULLY TRAVERSED.              04450000
         B     SYNT09              GO EXECUTE OLD PATH'S INTERP RULE.   04500000
*                                                                       04550000
*        NEXT  OBTAINS NEXT CODE SYLLABLE FROM CODESTRING (LOCATED      04600000
*              THROUGH STACKED ADDRESSES OF CODESTRING AND POINTER      04650000
*              WITHIN CODESTRING), CLASSIFIES IT AS LONG OR SHORT       04700000
*              (AND EST OR BST IF LONG), AND PLACES SYMBOL CLASS IN     04750000
*              'CLASS' AND (FOR LONG SYLLABLES) SPTR IN 'SPTR'.         04800000
*                                                                       04850000
SYNT07   CLI   NEXTOG,0            HAS CURRENT SYMBOL BEEN USED YET --  04900000
         BZ    SYNT05              NO.  TRY MATCHING IT TO THIS PATH.   04950000
         MVI   NEXTOG,0            YES.  GET NEXT SYL FROM CODESTRING.  05000000
         L     6,PARREL            LOCATE POINTERS IN STACK             05050000
         L     2,STCODE(6,MR)      PICK UP BASE ADDRESS OF CODESTRING   05100000
         LH    4,STCPTR(6,MR)      AND BYTE ADDRESS WITHIN CODESTRING.  05200000
         AR    2,4                 MVC NEEDS 1 BASE REGISTER            05250000
         ST    2,IRCPTR            SAVE CODE POINTER -- CONST INTERP    05300000
         AR    2,MR                RULE MAY WANT IT.                    05350000
         MVC   SYL,MCSORG-M-2(2)   MOVE NEXT 2 BYTES OF CODESTRING INTO 05400000
         LH    5,SYL               SYL AND INTO R5                      05450000
         BCTR  4,0                 DROP CODE POINTER BY 1               05500000
         TM    SYL+1,1             IS THIS SHORT OR LONG SYLLABLE --    05550000
         BO    SYNT01              SHORT                                05600000
         SLA   5,2                 LONG.  R5 IS DOUBLEWORD ADDRESS.     05650000
         BNM   SYNT12              LONG SYLLABLE MUST BE NEGATIVE.      05700000
         A     5,QR13STK           COMBINE BST POINTER AND RELATIVIZER  05750000
         ST    5,SPTR              SAVE SYMBOL ADDRESS IN SPTR          05800000
         IC    2,0(5,MR)           FIRST BYTE OF SYMBOL ENTRY IS CLASS. 05850000
         N     2,QF127             MAY HAVE FLAG INDICATING NOT M-PTR   05900000
         BCT   4,SYNT03            SAFE BECAUSE SHORT IS ALWAYS 1ST SYL 05950000
SYNT01   LA    LKR,SYLCLASS-1000   ESTABLISH ADDRESSABILITY OF SYLCLASS 06000000
         TRT   SYL+1(1),1000(LKR)  FIND CLASS FROM CLASS TABLE          06050000
SYNT03   STC   2,CLASS+1           SAVE CLASS FOR SYNTAX ANALYSIS.      06100000
         STH   4,STCPTR(6,MR)      SAVE CODE POINTER                    06150000
SYNT05   IC    3,DIAG+1(3)         ON TO THE NEXT PATH --               06200000
*                                                                       06250000
*        NOW WE HAVE SYMBOL CLASS IN 'CLASS' AND CURRENT PATH ADDR      06300000
*        IN R3.  PREPARE TO EXAMINE PATH AGAINST CLASS.                 06350000
*                                                                       06400000
SYNT11   LA    1,DIAG(3)                                                06450000
         CLI   0(1),TERMSYM        IS THIS PATH A TERMINAL SYMBOL --    06500000
         BL    SYNT08              YES.  GO COMPARE CLASSES.            06550000
         BE    SYNT09              NO.  IF PATH REPRESENTS EMPTY,       06600000
*                                  AUTOMATIC MATCH.                     06650000
         IC    2,BAKTOG                                                 06700000
         MVI   BAKTOG,0                                                 06750000
         OR    2,3                 PUSH PATH POSITION AND BAKTOG        06800000
         L     1,DIASTPTR          ONTO DIAGRAM STACK.                  06850000
         STC   2,DIAST(1)                                               06900000
         LA    1,1(1)              BUMP STACK POINTER                   06950000
         ST    1,DIASTPTR          AND SAVE IT.                         07000000
         BCTR  3,0                 SYNT05 PICKS UP FROM PATH, NOT CLASS 07050000
         C     1,DIASTOP           HAVE WE RUN OUT OF DIAGRAM STACK --  07100000
         BL    SYNT05              NO.  ANALYZE INNER DIAGRAM.          07150000
SYNTDE   LA    1,EDEPTH                                                 07200000
         B     GENER               COMMON CALL OF ERROR                 07250000
*                                                                       07300000
*              THE PATH REPRESENTS A TERMINAL SYMBOL                    07350000
*                                                                       07400000
SYNT08   CLC   CLASS+1(1),0(1)     DO CLASSES MATCH --                  07450000
         BNE   SYNT10              NO.                                  07500000
         MVI   NEXTOG,1            YES.  WE WILL TRAVERSE THIS PATH.    07550000
         MVI   BAKTOG,1            WE CAN'T BACK OUT OF THIS DIAGRAM    07600000
*                                                                       07650000
*              REENTRY FROM SYNTX AFTER TRAVERSING INNER DIAGRAM        07700000
*                                                                       07750000
SYNT09   ST    3,PATH              SAVE PATH ADDRESS                    07800000
         LA    LKR,DIIR-1000       ESTABLISH ADDRESSABILITY TO DIIR     07850000
         LH    3,1000(3,LKR)       BRANCH TO INTERPRETATION RULE        07900000
         B     SYNST1(3)                                                07950000
*                                                                       08000000
*              CLASSES DIDN'T MATCH.                                    08050000
*                                                                       08100000
SYNT10   LA    3,2(3)              PREPARE TO LOOK AT NEXT PATH         08150000
         TM    2(1),255            FROM THIS NODE.                      08200000
         BC    14,SYNT11           IS THERE ANOTHER PATH --             08250000
         TM    BAKTOG,1            NO.  HAVE WE GOBBLED ANY SYMBOLS     08300000
         BO    SYNT12              WITHIN THIS DIAGRAM --               08350000
*                                  YES.  SYNTAX ERROR.                  08400000
         C     3,NONSTMTD          NO.  IS THIS 'STMT' DIAGRAM --       08450000
         BL    SYNT12              YES.  NO OUTER DIAGRAM TO RETURN TO. 08500000
         L     1,DIASTPTR          POP THE DIAGRAM STACK.               08550000
         BCTR  1,0                 DROP POINTER                         08600000
         ST    1,DIASTPTR          AND SAVE IT.                         08650000
         IC    3,DIAST(1)          PICK UP PATH AND BAKTOG              08700000
         STC   3,BAKTOG            STORE AND ISOLATE BAKTOG             08750000
         NI    BAKTOG,1                                                 08800000
         N     3,QFE               THEN REMOVE BAKTOG FROM PATH.        08850000
         LA    1,DIAG(3)                                                08900000
         B     SYNT10                                                   08950000
*                                                                       09000000
*              SYNTAX ERROR                                             09050000
*                                                                       09100000
SYNT12   LA    1,ESYNTAX                                                09150000
         B     GENER               COMMON CALL OF ERROR                 09200000
*                                                                       09250000
DIASTOP  DC    F'498'              LIMIT FOR DIAGRAM STACK SIZE         09300000
DIASPEN  DC    F'494'              ALMOST LIMIT FOR DIAST, BUT WITH     09350000
*                                  ENOUGH SLOP TO ALLOW EXECUTION OF    09400000
*                                  SIMPLE STATEMENTS.                   09450000
NONSTMTD DC    A(NONSTMT)                                               09500000
QATMPCLS DC    AL1(CONST,0,0,0)                                         09550000
QAVARB   DC    AL1(VARB,0,0,0)                                          09600000
QAVMT    DC    AL1(VARB-CONST,0,0,0)                                    09650000
QASHADOW DC    AL1(SHADOW+X'80',0,0,0)                                  09700000
QF1      DC    F'1'                                                     09750000
QF3      DC    F'3'                                                     09800000
QF4      DC    F'4'                                                     09850000
QF8      DC    F'8'                                                     09900000
QF127    DC    F'127'                                                   09950000
QFE      DC    X'000000FE'                                              10000000
QF261    DC    F'261'                                                   10050000
QF15BITS DC    X'00007FFF'                                              10100000
QF24BITS DC    X'00FFFFFF'                                              10150000
QFBIT0   DC    X'80000000'                                              10200000
         TITLE 'I N T E R P R E T A T I O N   R U L E S       05/11/70' 10250000
*                                                                       10300000
*                                                                       10350000
*        STMT -- EXPRESSION TRAVERSED                                   10400000
IRS1     EQU   SYNTX                                                    10450000
*                                                                       10500000
*        STMT -- END-OF-STATEMENT PRECEDING EXPRESSION TRAVERSED        10550000
IRS2     EQU   *                                                        10600000
*                                                                       10650000
*        STMT -- END-OF-STATEMENT PRECEDING RIGHT ARROW TRAVERSED       10700000
IRS4     EQU   *                                                        10750000
         L     2,PARREL                                                 10800000
         AR    2,MR                R2 HOLDS ABSOLUTE ADDRESS OF STACKED 10850000
*                                  FUNCTION INFORMATION                 10900000
         CLI   SYL+1,1+2*ZEOS      A MISPLACED COLON COULD GET US HERE  10950000
         BE    IRS2E               SO GENERATE A SYNTAX ERROR IF NEITH- 11000000
         CLC   STCPTR(2,2),QH3     ER EOS NOR  LEOS  LABEL COLON        11050000
         BNE   SYNT12              LEOS, LABEL MUST BE REMAINING SYLS   11100000
         TM    SYL,1               SYL LEFT OF COLON MUST BE 16 BITS    11150000
         BO    SYNT12                                                   11200000
IRS2E    L     4,SVI                                                    11250000
         TM    STTRACE(2),STTRBIT  IS THIS STATEMENT BEING TRACED --    11300000
         BZ    IRS2A               NO.                                  11350000
         ICALL LOUTI               YES.  FORCE OUT ANY BUFFERRED TEXT,  11400000
         ICALL PLINF               PRINT FUNCTION NAME AND LINE NUMBER, 11450000
         B     IRS2B               THEN PRINT VALUE OF PRINCIPAL EXPN.  11500000
IRS2A    TM    STFLAGS(2),STQBIT+STQPBIT DUCK OUT NOW IF THIS EXPRESSIN 11550000
         BNZ   IRS2D               IS INPUT VALUE FOR QUAD OR QUAD-PRIM 11600000
         L     1,4(4,MR)           GET ENTRY ON TOP OF STACK            11650000
         N     1,QF24BITS         IS VALUE 'UNDEFINED' --               11700000
         BZ    IRS2F               YES.  PRINT NOTHING.                 11750000
         TM    STFLAGS(2),STSTBIT  OR, IF EXPRESSION IS NOT A COMPLETE  11800000
         BO    IRS2F               STATEMENT, PRINT JUST PRINCIPAL EXPN 11850000
IRS2B    L     1,4(4,MR)           LOAD WORD AT TOP OF STACK            11900000
*                                  NOW WE HAVE M-ENTRY POINTER          11950000
*                                  OF PRINTEE.  PRINT THE VALUE OF THE  12000000
         ICALL GOUT                M-ENTRY IN NORMAL OUTPUT FORMAT.     12050000
*              DO END-OF-STATEMENT PROCESSING -- FREE ANY REMAINING     12100000
*              TEMPS, BUMP LINE NUMBER IF STATEMENT WASN'T A BRANCH,    12150000
*              RESTORE CODESTRING TO FUNCTION DIRECTORY, AND            12200000
*              RETURN TO TYPEIN IF WE'RE IN IMMEDIATE EXECUTION.        12250000
IRS2F    L     3,PARREL            RESTORE ADDRESS OF FUNCTION INFO     12300000
         LR    2,3                 TO R2                                12350000
         S     3,QF4               ALSO RESTORE SVI TO POINT JUST BELOW 12400000
         ST    3,SVI               FUNCTION INFO IN STACK.              12450000
         L     1,0(3,MR)           PICK UP RESULT OF STATEMENT EXECUTN  12500000
         LTR   1,1                                                      12550000
         BNP   IRS2C               IF IT'S AN EXPRESSION,               12600000
         ICALL MKGARB              IT MUST BE MARKED AS GARBAGE.        12650000
*                                                                       12700000
*              REENTRY FROM IRS2U TO SKIP EXECUTION OF COMMENT LINE     12750000
IRS2C    BAL   LKR,IREOSB          PUT CODESTRING BACK IN FUNCTION      12800000
*                                  DIRECTORY UNLESS IT'S IMM-EX.        12850000
*              RETURN FOR IMM-EX                                        12900000
         B     IRS2G                                                    12950000
*              RETURN FOR FUN-EX                                        13000000
*              EXECUTED STATEMENT WAS PART OF A DEFINED                 13050000
*              FUNCTION.  ADJUST LINE COUNTER AND POSSIBLY EXIT         13100000
*              FROM THIS FUNCTION.                                      13150000
*                                                                       13200000
*        REENTRY FROM FUNCTION CALL SETUP AT IRB5D                      13250000
IRS2L    OI    RUNCTL,RCFNBIT      INDICATE STMT IN FUNCTION FOR IRS2FR 13300000
         TM    RUNCTL,RCOUTBIT+RCQEBIT+RCTRABIT WAS THIS STMT A BRANCH  13350000
         BZ    IRS2J               NO.                                  13400000
*                                                                       13450000
*        REENTRY FROM IRS2G IMM-EX BRANCH TO RESUME FN EXECUTION        13500000
IRS2H    L     4,BRVAL             STATEMENT WAS A BRANCH.              13550000
IRS2J    L     2,PARREL                                                 13600000
         LA    3,M(2)              RESET 'COMPLETE STATEMENT' AND       13650000
         MVI   STFLAGS(3),0        OTHER FLAGS                          13700000
         STH   4,STLINE(3)         GET NEW LINE NUMBER, AND PUT IT IN   13750000
*                                  STACKED LINE COUNTER.                13800000
         LTR   4,4                 NOW, IS LINE COUNTER OUT OF RANGE -- 13850000
         BNP   IRS2K               YES, IT'S NEGATIVE.                  13900000
         SH    4,MFLINES(5)        IT'S POSITIVE.  IS IT MORE THAN THE  13950000
*                                  LAST LINE OF THE FUNCTION --         14000000
         BM    IRS2Q               NO.  LINE NO. IS IN RANGE.           14050000
*              LINE NUMBER OUT OF RANGE.  RETURN FROM FUNCTION.         14100000
*              REENTRY FROM IMMEDIATE-EXECUTION CLEANUP AT IRS2G        14150000
*              NOW R2 = PARREL (M-RELATIVE)                             14200000
*                  R3 = PARREL (ABSOLUTE)                               14250000
*              WE MUST RESTORE SHADOWED VARIABLES TO THE BST AND MARK   14300000
*              GARBAGE ALL PARAMETERS AND LOCALS EXCEPT THE RESULT.     14350000
IRS2K    SR    1,1                 ASSUME FN RESULT NONEXISTENT         14400000
IRS2V    LR    6,1                 SAVE ADDR OF RESULT M-ENTRY          14450000
IRS2T    LA    3,8(3)              ADVANCE TO NEXT SAVED SHADOW         14500000
         CLI   STSHADOW(3),SHADOW+X'80' HAVE WE REACHED END OF LIST     14550000
         BNE   IRS2M               -- YES.  ALL DONE.                   14600000
         LM    4,5,STSHADOW(3) ,STPARAM  LOAD BST POINTER AND MPTR      14650000
         N     4,QF24BITS          IF NONEXISTENT PARAMETER,            14700000
*                                  AVOID THE POINTER-FLIPPING GAMES.    14750000
         L     1,M(4)              ALLOW UNNAMED, NON-SHADOWING LOCALS  14800000
         BNZ   IRS2TA              TO RESIDE IN STACK WHERE GLOBAL      14850000
         LTR   1,5                 IS NORMALLY STORED.  CONDITION INDI- 14900000
         BNP   IRS2T               CATED BY ZERO ADDR FIELD OF SHADOW.  14950000
IRS2TA   ST    5,M(4)              RESTORE GLOBAL VALUE TO SYMBOL TABLE 15000000
*                                  (OR TO M(0) IF UNNAMED LOCAL)        15050000
         LTR   5,5                                                      15100000
         BM    IRS2S               IF S.T. ENTRY IS M-POINTER,          15150000
         IC    7,MHEAD(5)          POINT GLOBAL'S M-ENTRY AT BST        15250000
         ST    4,MHEAD(5)          *** NOTE THAT IF OUTER VALUE WAS     15300000
*                                  UNDEFINED, WE ARE STORING IN WORD 0  15350000
*                                  OF THE WORKSPACE.  THIS IS HARMLESS  15400000
*                                  AND PROBABLY NOT WORTH CHECKING FOR. 15450000
         STC   7,MHEAD(5)                                               15500000
IRS2S    CLI   STSHADOW-8(3),SHADOW+X'80' IF FIRST PARAM, NO SHADOW     15550000
         BNE   IRS2V               PRECEDES.  SKIP GARBAGE MARKING AND  15600000
*                                  RETAIN ADDRESS OF RESULT M-ENTRY.    15650000
         ICALL MKGARB              OTHERWISE ERASE LOCAL VALUE.         15700000
         B     IRS2T                                                    15750000
IRS2M    NI    RUNCTL,255-RCFNBIT-RCTRABIT CLEAR FLAG INDICATING        15800000
*                                  POSSIBILITY OF PROGRAMMED STOP.      15850000
         LA    3,STSHADOW-8(3)     SET SVI TO ALLOW ROOM FOR FN VALUE   15900000
         SR    3,MR                                                     15950000
         ST    3,SVI                                                    16000000
*                                  PARAM NO. 1 (IN R6) IS RESULT.       16050000
         LA    3,4(3)              PUT IT JUST ABOVE NEW SVI.           16100000
         LTR   6,6                 IS IT INDIRECT PTR (POSSIBLE ONLY    16150000
         BM    IRS2P               FOR QUAD) --                         16200000
         N     6,QF24BITS          IS IT UNDEFINED (FUNCTION HAS        16250000
*                                  NO VALUE) --                         16300000
         BZ    IRS2P               YES.                                 16350000
*        CODE AT IRS2D MAKES IT NECESSARY THAT THIS ADJUSTMENT BE DONE  16400000
*        BY REPLACING MHEAD ADDRESS RATHER THAN BY INCREMENTING IT.     16450000
         IC    0,MHEAD(6)          SAVE FLAG BYTE                   A03 16550000
         ST    3,MHEAD(6)          NO.  SET M-ENTRY HEADER TO NEW       16600000
*                                  STACK LOCATION.                      16650000
         STC   0,MHEAD(6)          RESTORE FLAG BYTE                A03 16700000
         O     6,QATMPCLS          MAKE RESULT A TEMP, NOT A VARB.      16750000
IRS2P    ST    6,0(3,MR)           NOW PUT RESULT EST ENTRY IN NEW      16800000
*                                  STACK POSITION.                      16850000
         L     2,STFREG(2,MR)      PARREL NOW POINTS TO OUTER FUNCTION  16900000
         ST    2,PARREL            STACK INFO.                          16950000
         MVI   NEXTOG,1            RE-ESTABLISH SYNTAX ANALYSIS FOR FN. 17000000
         L     1,DIASTPTR          DROP DIAGRAM STACK POINTER.          17050000
         BCTR  1,0                                                      17100000
         ST    1,DIASTPTR                                               17150000
         SR    0,0                                                      17200000
         IC    0,DIAST(1)          AND PICK UP ADDRESS OF PATH WE WERE  17250000
         ST    0,PATH              WORKING ON                           17300000
         MVI   BAKTOG,1            BAKTOG IS ON, SINCE FN WAS SCANNED.  17350000
         BAL   LKR,IRS2FR          RE-ESTABLISH CODESTRING POINTER FOR  17400000
*                                  OUTER FUNCTION.                      17450000
         TM    RUNCTL,RCOLBIT      IF IN THE PROCESS OF EXITING FROM    17500000
         BO    SYNT12              LOCKED FNS, LET ERROR CONTINUE.      17550000
         TM    RUNCTL,RCOUTBIT+RCQEBIT IF FN EXIT IS BEING FORCED,      17600000
         BZ    IRS2N               (IT'S NOT)                           17650000
         ICALL ERAST               TREAT ALMOST LIKE ERROR IN OUTER FN  17700000
         L     2,PARREL            (RESTORE AFTER ERAST)                17750000
         B     IRS2C               AND THEN LEAVE OUTER FN AS WELL.     17800000
*              NOTE THAT BRVAL IS STILL OUT OF RANGE FROM SETTING       17850000
*              AT IRS5                                                  17900000
*                                                                       17950000
*        REENTRY FROM IRS2FR IF PENDENT FUNCTION HAS BEEN ERASED        18000000
IRS2I    ICALL ERAST               SIMPLY RETURN FROM THE EX-FUNCTION   18050000
         BAL   4,IRS2J             ILC BECOMES OUT-OF-RANGE BRANCH ADDR 18100000
*                                                                       18150000
IRS2N    LTR   6,6                 IF FUNCTION RETURNED NO VALUE,       18200000
         BNZ   SYNTX               (IT DID)                             18250000
         BAL   LKR,CSTSUB          MAKE SURE IT STANDS AS A COMPLETE    18300000
         B     SVALER              STATEMENT (IT DOESN'T)               18350000
         B     SYNTX               RESUME EXECUTION OF OUTER FUNCTION.  18400000
*                                                                       18450000
*        THIS STATEMENT IS INPUT VALUE FOR QUAD OR QUAD-PRIME.          18500000
IRS2D    LA    1,4(4)              (TRICKY) MAKE SHADOW PTR FOR PARAM 1 18550000
         ST    1,STSHADOW+8(2)     POINT TO STACKED RESULT OF QUAD EXCN 18600000
         MVI   STSHADOW+8(2),SHADOW+X'80' WHICH IRS2M WILL RELOCATE.    18650000
         OI    RUNCTL,RCTRABIT     FAKE A BRANCH TO GET US OUT OF 'DFN' 18700000
         MVI   BRVAL,X'C0'         ENSURE BRANCH OUT OF RANGE IN CASE   18750000
*                                  OF QUAD-PRIME 'OUT' OPERATION        18800000
*                                  WHICH DIDN'T GO THROUGH IRS5         18850000
*                                                                       18900000
*              THIS IS IMMEDIATE-EXECUTION STATEMENT.                   18950000
IRS2G    L     1,STCODE(2)         FIND BASE ADDR OF CODESTRING         19000000
         N     1,QF24BITS                                               19050000
         MKG   1                   AND MARK IT GARBAGE.                 19100000
         L     1,STFREG(2)         IF EX STACK LIST POINTER IS ZERO     19150000
         LTR   1,1                 WE'RE ON THE OUTERMOST LEVEL.        19200000
         BZ    IRS2Z               IGNORE POSSIBLE BRANCH AND RETURN.   19250000
         TM    RUNCTL,RCTRABIT     WAS THE STATEMENT A BRANCH --        19300000
         BO    IRS2R               YES.  CONTINUE EXECUTION.            19350000
         TM    RUNCTL,RCOUTBIT+RCQEBIT IF THIS IS FORCED BRANCH OUT     19400000
         BZ    IRS2Z                                                    19450000
         TM    STFLAGS(2),STQBIT   AND THIS LEVEL IS QUAD 'FN',         19500000
         BZ    IRS2Z                                                    19550000
*                                  LEAVE IT TOO                         19600000
IRS2R    L     1,STFNSPTR(2)       IF FUNCTION BST POINTER IS ZERO,     19650000
         LR    3,2                 (ABSOLUTE PARREL)                    19700000
         SR    2,MR                                                     19750000
         LTR   1,1                 THE USER HAS DELETED THE FUNCTION    19800000
         BZ    IRS2K               HE WANTS US TO EXECUTE (OR 'FN' IS   19850000
*                                  A QUAD OR QUAD-PRIME.)               19900000
         NI    RUNCTL,255-RCFNBIT  OTHERWISE, AVOID POSSIBILITY OF      19950000
         B     IRS2H               PROGRAMMED STOP AND RESUME FN EXECN. 20000000
         PRINT GEN                                                      20050000
*                                                                       20100000
*        REENTRY FROM IRB5D TO EXECUTE QUAD (QUAD-PRIME) INPUT REQUEST  20150000
IRS2Z    NI    RUNCTL,255-RCQEBIT  WE'VE ESCAPED FROM QUAD-PRIME TRAP   20200000
         ATT   ON=IRS2W,OFF=IRS2X,RESET=YES  IF ATTENTION IS SET,       20250000
*                                  PRINT CR TO GET CARRIAGE AT LEFT MGN 20300000
IRS2ZA   TCOM  RECEIVE            RECEIVE A PA OR MSG, RETEST ATTN  A01 20350000
*                                                                       20400000
*        LINE NUMBER IS IN RANGE OF THIS FUNCTION.                      20450000
IRS2Q    EQU   *                                                        20500000
         L     1,MPTBASE           THE ATTENTION MACRO CAN'T HANDLE A   20550000
         TM    IOB2-PERTERM(1),BOUNCM   TEST ON BOUNCM.                 20600000
         BO    IRS2Y                                                    20650000
         ATT   OFF=IRS2U,PAON=IRS2ZA,RESET=NO,MPTBASE=(1)               20700000
*                                                                       20750000
IRS2Y    ATT   RESET=YES                                                20800000
         PRINT NOGEN                                                    20850000
         ICALL LOUT                MAKE SURE CARRIAGE IS AT MARGIN      20900000
         TYO   IRS2IDL             AN ATTENTION SIGNAL WOULD HAVE SUP-  20950000
*                                  PRESSED TRAILING IDLES OF PREVIOUS   21000000
*                                  OUTPUT LINE.  PRINT SOME IDLES TO    21050000
*                                  HELP CARRIER GET TO LEFT MARGIN.     21100000
         AR    5,MR                LOCKED FUNCTIONS REFUSE TO GIVE UP   21150000
         TM    MHEAD-M(5),MFLKBIT  WE MAY BE LOOKING AT BYTE 0 OF MX    21200000
         LA    1,EINT              GIVE HIM 'INTERRUPT' MESSAGE         21250000
         BO    GENER                                                    21300000
         ICALL PLINF               PRINT FUNCTION NAME AND              21350000
IRS2W    ICALL LOUT                LINE NUMBER.                         21400000
IRS2X    IRETURN                   RETURN TO TYPEWRITER.                21450000
*                  IDLE CHARACTERS FOR 2741                             21500000
IRS2IDL  DC    AL1(0,7,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB,ZEOB)         21550000
*                                                                       21600000
*        EXECUTE NEXT LINE OF FUNCTION.                                 21650000
IRS2U    BAL   LKR,IRS2FR          PUT CODESTRING ADDRESS IN STACK      21700000
         NI    RUNCTL,255-RCTRABIT ERASE BRANCH-STMT BIT                21750000
         AR    5,MR                                                     21800000
         CLI   MCSORG-M(5),1+2*ZREM  IF THIS IS A COMMENT LINE,         21850000
         BE    IRS2C               IGNORE IT UTTERLY.                   21900000
         LH    1,MCSCNT-M(5)       SET CODE-POINTER TO RIGHTMOST        21950000
         STH   1,STCPTR(2,MR)      SYLLABLE OF STATEMENT                22000000
         B     SYNST1              AND EXECUTE IT.                      22050000
*                                                                       22100000
*        SET UP CODESTRING BASE ADDRESS OF OUTER FUNCTION.              22150000
*        ADDRESS IS OBTAINED FROM FUNCTION DIRECTORY IN M, THEN REMOVED 22200000
*        FROM DIRECTORY AND LINKED TO CODE ADDRESS IN STACK.            22250000
*        CPTR WORD IN STACK IS NOT ALTERED.                             22300000
*        IF CURRENT STATEMENT IN OUTER FUNCTION IS IMMEDIATE-EXECUTION  22350000
*        STATEMENT, RETURNS IMMEDIATELY SINCE CODESTRING IS STILL       22400000
*        ESTABLISHED.                                                   22450000
*        ON ENTRY, R2 = EX STACK SETTING FOR OUTER FUNCTION (PARREL)    22500000
*                  R0, R1, R3, R5 USED AS TEMPS                         22550000
*        ON EXIT,  R2 UNCHANGED                                         22600000
*                  R5 MPTR OF CODESTRING                                22650000
IRS2FR   LA    3,0(2,MR)                                                22700000
         TM    STFLAGS(3),STIMBIT  IF STATEMENT BEING EXECUTED IS       22750000
         BCR   7,LKR               IMMEDIATE-EXECUTION, RETURN.         22800000
         L     1,STFNSPTR(3)       GET ADDRESS OF FUNCTION BST ENTRY    22850000
         LTR   1,1                 TEST FOR UNUSUAL CASE OF PENDENT     22900000
         BZ    IRS2I               FUNCTION ERASED FROM STACK.          22950000
         L     1,M(1)              THEN MPTR OF FUNCTION DIRECTORY      23050000
         LH    0,STLINE(2,MR)      LOAD LINE NUMBER                     23150000
         SLA   0,2                 MAKE IT A WORD INDEX                 23200000
         AR    1,0                 R1 IS RELATIVE POINTER TO LINE       23250000
         AR    1,MR                NOW ABSOLUTE                         23300000
         TM    MFCODE-M(1),STPSBIT IS A STOP REQUESTED FOR THIS LINE -- 23350000
         BZ    IRS2FR2             NO.                                  23400000
         LA    5,MX-M              SNEAKY 0 FOR LOCKED FN TEST          23450000
         TM    RUNCTL,RCFNBIT      YES.  DID WE GET HERE VIA IMM-EX     23500000
*                                  BRANCH OR A FUNCTION RETURN --       23550000
         BNZ   IRS2Y               NO.  STOP EXECUTION.                 23600000
IRS2FR2  L     5,MFCODE-M(1)       PICK UP MPTR OF CODESTRING           23650000
         LA    3,STCODE(2)         R3 = CODESTRING ADDRESS IN FN-INFO   23700000
         ST    5,M(3)              STORE CODESTRING MPTR, CODESTRING    23750000
*                                  CLASS, AND TRACE BIT                 23800000
         ST    3,MHEAD(5)          INSTEAD OF TO FUNCTION DIRECTORY     23900000
         SR    3,3                 CLEAR CODESTRING MPTR IN DIRECTORY   23950000
         ST    3,MFCODE-M(1)                                            24000000
         BR    LKR                 RETURN                               24050000
*                                                                       24100000
*        SUBROUTINE TO REPLACE STACKED CODESTRING ADDRESS IN FUNCTION   24150000
*        DIRECTORY.  IF STATEMENT IS IMMEDIATE-EXECUTION, RETURNS TO    24200000
*        0(LKR)  WITHOUT AFFECTING STACK.  OTHERWISE REPLACES  STCODE,  24250000
*        CLEARS STACK POSITION, POINTS CODESTRING M-ENTRY TO FUNCTION   24300000
*        DIRECTORY, AND RETURNS TO  4(LKR) .                            24350000
*        ON ENTRY,                                                      24400000
*              R2 = PARREL (M-RELATIVE)                                 24450000
*        ON EXIT,                                                       24500000
*              R2 = PARREL (ABSOLUTE)                                   24550000
*              R4 = 1 + CURRENT LINE OF FUNCTION (IF NOT IMM-EXC)       24600000
*              R5 = ADDRESS OF DIRECTORY (M-RELATIVE)                   24650000
*                                                                       24700000
IREOSB   AR    2,MR                GET ABSOLUTE PARREL                  24750000
         L     1,STFNSPTR(2)       FIND ADDRESS OF FUNCTION DIRECTORY   24800000
         L     5,0(1,MR)           R5 POINTS TO DIRECTORY               24900000
         TM    STFLAGS(2),STIMBIT  WAS THIS AN IMMEDIATE-EXECUTION      25000000
         BCR   7,LKR               STATEMENT --                         25050000
         LH    3,STLINE(2)         FIRST RESTORE CODESTRING ADDRESS TO  25100000
*                                  FUNCTION DIRECTORY.                  25150000
         LA    4,1(3)              R4 IS NO. OF NEXT SEQUENTIAL STMT    25200000
         SLA   3,2                 LOCATE POSITION IN DIRECTORY FROM    25250000
         LA    1,MFCODE-M(5,3)     DIRECTORY ADDRESS AND LINE COUNTER.  25300000
         L     3,STCODE(2)         PICK UP BASE ADDRESS OF CODESTRING   25350000
         ST    3,M(1)              STORE IT IN DIRECTORY                25400000
         XC    STCODE(4,2),STCODE(2)   CLEAR STACK POSITION OF POINTER  25550000
         ST    1,M(3)              AND STORE LINK TO DIRECTORY IN       25600000
         B     4(LKR)              CODESTRING.                          25650000
*                                                                       25700000
*        STMT -- RIGHT ARROW TRAVERSED                                  25750000
IRS3     EQU   *                                                        25800000
         L     1,SVI               FIND BRANCH VALUE                    25850000
         L     1,M+4(1)            ON TOP OF STACK.                     25900000
         LTR   1,1                                                      25950000
         BP    IRS3E               GET M-POINTER IF IT'S AN             26000000
         L     1,M(1)                                                   26100000
IRS3E    DS    0H                                                       26150000
         LR    4,1                                                      26200000
         AR    1,MR                CHECK FOR LIST                       26250000
         TM    MLIST-M(1),MLSTBIT  (ILLEGAL)                            26300000
         BO    SYNT12                                                   26350000
         OI    RUNCTL,RCTRABIT     INDICATE BRANCH STMT FOR IRS2 LOGIC  26400000
         LH    0,MRANK-M(1)        LOOK AT RANK                         26450000
         C     0,QF4                                                    26500000
         BL    IRS3A               SCALAR.  UNCONDITIONAL BRANCH.       26550000
         BH    IRS3B               MATRIX OR HIGHER.  RANK ERROR.       26600000
         L     0,MRHO-M(1)         VECTOR.  LOOK AT ITS LENGTH.         26650000
         LTR   0,0                                                      26700000
         BZ    IRS3C               LENGTH ZERO MEANS FALL THROUGH.      26750000
*        BRANCH EXPRESSION IS NONEMPTY.  BRANCH TO 1ST COMPONENT.       26800000
IRS3A    AH    4,MRANK-M(1)        LOCATE FIRST ELEMENT                 26850000
         LA    4,MRHO-M(4)         PUT ADDRESS IN R4                    26900000
         SR    2,2                 INDEX (ZERO) IN R2                   26950000
         LR    3,2                 TYPE IN R3                           27000000
         IC    3,MTYPE-M(1)                                             27050000
         ICALL FETCHINT            AND GET INTEGER VALUE.               27100000
         B     IRS3D                                                    27150000
*              BRANCH TO EMPTY VECTOR FALLS THROUGH TO FOLLOWING STATE- 27200000
*              MENT.                                                    27250000
IRS3C    L     1,PARREL            FIND LINE NUMBER IN STACKED FUNCTION 27300000
         LH    1,STLINE(1,MR)      INFORMATION.                         27350000
         LA    0,1(1)              ADD 1 TO IT AND FAKE A BRANCH.       27400000
IRS3D    ST    0,BRVAL             SAVE NEW LINE NUMBER FOR END-OF-STMT 27450000
*                                  LOGIC.                               27500000
         L     1,PARREL                                                 27550000
         AR    1,MR                INDICATE A COMPLETE STATEMENT        27600000
         OI    STFLAGS(1),STSTBIT  TO BYPASS EXPRESSION DISPLAY.        27650000
         B     SYNTX                                                    27700000
IRS3B    LA    1,ERANK             BRANCH TO MATRIX IS A RANK ERROR     27750000
         B     GENER               COMMON CALL OF ERROR                 27800000
*                                                                       27850000
*        STMT -- ISOLATED RIGHT ARROW TRAVERSED                         27900000
IRS5     EQU   *                                                        27950000
         OI    RUNCTL,RCOUTBIT+RCTRABIT INDICATE WHOLESALE EXIT         28000000
         SR    1,1                 FOR IRS2                             28050000
         BAL   8,PUSH              STACK MUST HOLD  S O M E  VALUE      28100000
         BAL   0,IRS3D             GENERATE THOROUGHLY OUT-OF-RANGE     28150000
*                                  LINE NUMBER AND JOIN BRANCH CODE.    28200000
*                                                                       28250000
*        STMT -- SEMICOLON ON PAREN LEVEL ZERO TRAVERSED                28300000
IRS6     EQU   *                                                    A04 28350000
         L     2,PARREL                                             A04 28400000
         AR    2,MR                                                 A04 28450000
         TM    STFLAGS(2),STQBIT   WAS LIST INPUTTED VIA QUAD?      A04 28500000
         BZ    SYNTX               BRANCH IF NO                     A04 28550000
         B     SYNT12              BRANCH IF YES, SYNTAX ERROR.     A04 28600000
*                                                                       28650000
*        LIST -- SEMICOLON AS RIGHTMOST SYMBOL TRAVERSED                28700000
IRL1     EQU   *                                                        28750000
*                                                                       28800000
*        LIST -- EXPRESSION TRAVERSED                                   28850000
IRL2     EQU   SYNTX                                                    28900000
*                                                                       28950000
*        LIST -- 'EMPTY' PRECEDING SEMICOLON OR AS ENTIRE LIST TRAVERSD 29000000
IRL3     EQU   *                                                        29050000
         SR    1,1                 PUT AN 'EMPTY' FLAG ON THE STACK     29100000
         BAL   8,PUSH                                                   29150000
         B     SYNTX                                                    29200000
*                                                                       29250000
*        LIST -- SEMICOLON PRECEDING EXPRESSION TRAVERSED               29300000
IRL4     EQU   SYNTX                                                    29350000
*                                                                       29400000
*        LIST -- 'EMPTY' PRECEDING EXPRESSION TRAVERSED                 29450000
IRL5     EQU   SYNTX                                                    29500000
*                                                                       29550000
*        BASIC -- UNSUBSCRIPTED VARIABLE TRAVERSED                      29600000
IRB1     EQU   *                                                        29650000
*                                                                       29700000
*        BASIC -- SUBSCRIPTED VARIABLE TRAVERSED                        29750000
IRB10    EQU   *                                                        29800000
*                                                                       29850000
*        EXP -- DEFINED FUNCTION WITH PARAMETERS TRAVERSED              29900000
IRE4     EQU   *                                                        29950000
*                                                                       30000000
*        EXP -- SUBSCRIPTED VARIABLE LEFT OF OPERATOR TRAVERSED         30050000
IRE31    EQU   *                                                        30100000
         TM    SYL+1,1             SHORT SYLLABLE IS QUAD OR QUAD-PRIME 30150000
         BO    IRB5I               ON RIGHT.  FAKE A DFN CALL.          30200000
IRB2F    L     1,SPTR                                                   30250000
         L     0,M(1)              PICK UP BST ENTRY                    30300000
         N     0,QF24BITS          IS IT DEFINED --                     30350000
         BNZ   IRB1A               YES.                                 30400000
SVALER   EQU   *                                                        30450000
         LA    1,EVALUE            NO.  VALUE ERROR.                    30500000
GENER    ICALL ERROR                                                    30550000
*                                  STACK SIGN-BIT-FLAGGED POINTER       30600000
IRB1A    O     1,QFBIT0            TO SYMBOL TABLE (BST OR EST) ENTRY   30650000
         BAL   8,PUSH              ON STACK.                            30700000
         B     SYNTX                                                    30750000
*                                                                       30800000
*        BASIC -- UNSUBSCRIPTED CONSTANT TRAVERSED                      30850000
IRB2     EQU   *                                                        30900000
*                                                                       30950000
*        BASIC -- SUBSCRIPTED CONSTANT TRAVERSED                        31000000
IRB16    EQU   *                                                        31050000
*                                                                       31100000
*        EXP -- SUBSCRIPTED CONSTANT LEFT OF OPERATOR TRAVERSED         31150000
IRE43    EQU   *                                                        31200000
         TM    SYL+1,1             LONG SYLLABLE IS A LOCAL LABEL       31250000
         BZ    IRB2F               OR OTHER RELATIVE CONSTANT           31300000
         SR    2,2                                                      31350000
         TRT   SYL+1(1),IRB2TB     GET CONSTANT TYPE FROM SYLLABLE      31400000
         LA    1,ERANGE            DOMAIN ERROR IF THIS IS AN ERROR     31450000
         BZ    GENER               CONSTANT. (FOR FNS BEFORE APRIL 69)  31500000
IRB2W    ST    2,FTEMP1            SAVE TYPE FOR INSERTION IN M-ENTRY   31550000
         L     1,IRCPTR            RECALL M-RELATIVE CODE POINTER       31600000
         AR    1,MR                MOVE 16-BIT CONSTANT COUNT FROM      31650000
         MVC   HTEMP(2),MCSORG-M-3(1)  CODESTRING TO HTEMP              31700000
         LH    1,HTEMP                                                  31750000
         LR    4,1                 CONSTANT COUNT NOW IN R1 AND R4      31800000
         IC    2,IRB2S-1(2)        PICK UP APPROPRIATE SHIFT FOR THIS   31850000
         SLL   1,0(2)              TYPE.                                31900000
         LA    1,7(1)              FOR BOOLEAN TYPE, ROUND BITS UP TO   31950000
         SRL   1,3                 NEXT BYTE, THEN DISCARD BIT COUNT.   32000000
QH3      EQU   *-2                                                      32050000
         ST    1,FTEMP2            FINALLY SAVE COUNT FOR MVC OPERATION 32100000
         LA    1,MRHO-M+4(1)       COMPUTE STORAGE REQUIREMENT FOR      32150000
         BCT   4,IRB2A             M-ENTRY HEADER, INCLUDING 4 BYTES    32200000
         S     1,QF4               FOR DIMENSION IF CONSTANT COUNT      32250000
*                                  ISN'T 1.                             32300000
IRB2A    SR    2,2                 TELL GETSPACE TO PUT EST ENTRY       32350000
         ICALL GETSPACE            ON STACK .                           32400000
         LA    5,MRHO(1)                                                32450000
         LH    3,HTEMP             SET UP RANK VECTOR                   32500000
         SR    4,4                 RANK 0 IF CONSTANT COUNT IS 1        32550000
         C     3,QF1               IS IT --                             32600000
         BE    IRB2C               YES.                                 32650000
         LA    4,4                 NO.  RANK IS 1                       32700000
         AR    5,4                 BUMP DATA ADDRESS                    32750000
         ST    3,MRHO(1)           STORE RANK VECTOR.                   32800000
IRB2C    ST    4,MRANK-2(1)        STORE RANK (CLEARING TYPE ETC)       32900000
         L     0,FTEMP1            INSERT CONSTANT TYPE INTO HEADER     32950000
         STC   0,MTYPE(1)                                               33000000
         L     2,PARREL            RECALL CODESTRING POINTER            33050000
         LH    3,STCPTR(2,MR)      FROM STACK.                          33100000
         BCTR  3,0                                                      33150000
         BCTR  3,0                 DECREASE IT BY 2 BYTES OF COUNT SYL  33200000
         L     4,FTEMP2            AND BY BYTE COUNT OF CONSTANT.       33250000
         SR    3,4                                                      33300000
         STH   3,STCPTR(2,MR)      RETURN IT TO STACK.                  33350000
         A     3,STCODE(2,MR)      ADD IN BASE ADDRESS OF CODESTRING    33400000
         AR    3,MR                AND WORKSPACE ADDRESS                33500000
         S     4,QF1               DROP BYTE COUNT FOR MVC              33550000
         BM    SYNTX               NO MOVE FOR  ''  CONSTANT            33600000
         LA    1,256               SET UP FOR MOVE LOOP.                33650000
IRB2E    SR    4,1                 IS BYTE COUNT GTR 256 --             33700000
         BM    IRB2D               NO.  DO A SHORT MOVE.                33750000
         MVC   0(256,5),MCSORG-M(3) YES. MOVE 256 BYTES FROM CODESTRING 33800000
         AR    5,1                 TO M-ENTRY DATA AREA, THEN UPDATE    33850000
         AR    3,1                 SOURCE AND SINK ADDRESSES BY 256.    33900000
         B     IRB2E               BACK FOR NEXT MOVE.                  33950000
IRB2D    EX    4,IRB2M             SHORT MOVE. EXECUTE MVC.             34000000
         B     SYNTX               BACK TO SYNTAX ANALYSIS              34050000
IRB2S    DC    FL1'0,5,6,3'        TABLE OF LEFT SHIFTS ON TYPE         34100000
IRB2TB   EQU   *-(ZECONST*2+1)                                          34150000
         DC    FL1'0,0,1,0,2,0,3,0,4'  TYPE-FROM-SYL TABLE              34200000
IRB2M    MVC   0(0,5),MCSORG-M(3)  EXECUTED MOVE INSTRUCTION            34250000
*                                                                       34300000
*        BASIC -- UNSUBSCRIPTED RIGHT PARENTHESIS TRAVERSED             34350000
IRB3     EQU   *                                                        34400000
*                                                                       34450000
*        BASIC -- RIGHT BRACKET TRAVERSED                               34500000
IRB4     EQU   *                                                        34550000
*                                                                       34600000
*        BASIC -- SUBSCRIPTED RIGHT PARENTHESIS TRAVERSED               34650000
IRB11    EQU   *                                                        34700000
*                                                                       34750000
*        EXP -- RIGHT BRACKET OF OPERATOR SUBSCRIPT TRAVERSED           34800000
IRE6     EQU   *                                                        34850000
*                                                                       34900000
*        EXP -- RIGHT BRACKET TRAVERSED                                 34950000
IRE12    EQU   *                                                        35000000
*                                                                       35050000
*        EXP -- RIGHT BRACKET OF LHS TRAVERSED                          35100000
IRE19    EQU   *                                                        35150000
*                                                                       35200000
*        EXP -- RIGHT PARENTHESIS OF SUBSCRIPTED EXPRESSION LEFT OF     35250000
*              OPERATOR TRAVERSED                                       35300000
IRE32    EQU   *                                                        35350000
         LA    1,1                 PUT A ONE ON STACK TO MARK END OF    35400000
         BAL   8,PUSH              LIST IN CASE THIS IS PARENTHESIZED   35450000
         B     SYNTX               LIST.                                35500000
         EJECT                                                          35550000
*                                                                       35600000
*              MONADIC DEFINED FUNCTION TO BE EXECUTED                  35650000
IRE13A   EQU   *                                                        35700000
*              ON ENTRY, R1 = FUNCTION SPTR                             35750000
*                        R5 = SVI                                       35800000
         LA    2,1                 SET R2 = MONADIC DFN                 35850000
         SR    8,8                 INITIALIZE ARGUMENT SPACE            35900000
         B     IRB5Q                                                    35950000
*                                                                       36000000
*              DYADIC DEFINED FUNCTION TO BE EXECUTED                   36050000
*              ON ENTRY, R1 = FUNCTION SPTR                             36100000
*                        R5 = SVI                                       36150000
IRE8A    EQU   *                                                        36200000
         LA    2,2                 SET R2 = DYADIC DFN                  36250000
         SR    8,8                 INITIALIZE ARGUMENT SPACE            36300000
         BAL   LKR,IRB5SC          ADD IN SPACE FOR LEFT ARG            36350000
         LA    5,4(5)              ADVANCE TOWARD RIGHT ARG             36400000
*              COMMON POINT FOR MONADIC AND DYADIC DFNS                 36450000
IRB5Q    LA    5,4(5)              R5 = RARG ADDR - 4                   36500000
         BAL   LKR,IRB5SC          ADD IN SPACE FOR RIGHT ARG           36550000
         ST    1,SPTR              SAVE FUNCTION S.T. POINTER           36600000
         L     6,M(1)              PICK UP FUNCTION DIRECTORY ADDRESS   36700000
         LA    0,X'F'              EXTRACT NUMBER OF PARAMS             36800000
         N     0,MFLCLS(6)                                              36900000
         CR    2,0                 DOES NO. OF ARGS MATCH NO. OF        36950000
         LA    2,1(2)                                                   37000000
         BE    IRB5C               PARAMS --                            37050000
         B     SYNT12              NO.  SYNTAX ERROR.                   37100000
*                                                                       37150000
*        QUAD OR QUAD-PRIME ON RIGHT TRAVERSED                          37200000
IRB5I    SR    8,8                 INITIALIZE ARGUMENT SPACE            37250000
         LA    2,(STIMBIT+STQBIT+STQPBIT)*256                           37300000
         CLI   SYL+1,ZQUAD*2+1     WHICH IS IT --                       37350000
         BNE   IRB5J               QUAD-PRIME                           37400000
         LA    2,(STIMBIT+STQBIT)*256  QUAD                             37450000
         B     IRB5J                                                    37500000
IRB5F    LA    2,0(6)              S.T. IS IMM DATA FOR KEYWORD 'DFN'   37550000
IRB5J    SR    6,6                                                      37650000
         ST    6,SPTR              CLEAR SPTR TO AVOID LATER CONFUSION  37700000
*                                  WITH GENUINE DFN                     37750000
         B     IRB5C                                                    37800000
*                                                                       37850000
IRB5SC   L     3,M+4(5)            ADD SPACE NEEDED FOR ARGUMENT TO R8  37900000
         LTR   3,3                 ON ENTRY, R5 = ARG STACK ADDR - 4    37950000
         BCR   11,LKR              NO EXTRA SPACE NEEDED IF ARG IS EXPN 38000000
         L     3,M(3)              FOR VARB, GO INDIRECT THROUGH S.T.   38050000
         A     8,MCOUNT(3)         ADD IN SPACE CURRENTLY USED          38150000
         BR    LKR                                                      38200000
*                                                                       38250000
*        BASIC -- DFN0 TRAVERSED                                        38300000
IRB5     EQU   *                                                        38350000
*                                                                       38400000
*        BASIC -- SUBSCRIPTED DFN0 TRAVERSED                            38450000
IRB12    EQU   *                                                        38500000
*                                                                       38550000
*        EXP -- SUBSCRIPTED DFN0 LEFT OF OPERATOR TRAVERSED             38600000
IRE35    EQU   *                                                        38650000
         SR    8,8                 NO SPACE NEEDED FOR ARGUMENTS        38700000
         L     6,SPTR              PICK UP POINTER TO FN BST ENTRY      38750000
         L     6,M(6)              THEN POINTER TO FUNCTION DIRECTORY   38800000
         SR    2,2                 SET R2 = DFN0                        38900000
IRB5C    CLI   NEXTOG,0            IF WE HAVE ADVANCED PAST LEFT ARG    38950000
         BNE   IRB5H               (OR FUNCTION NAME, IF NO LEFT ARG),  39000000
         L     3,PARREL            CODESTRING POINTER MUST BE BACKED    39050000
         LH    1,STCPTR(3,MR)      OFF BY ONE SYLLABLE.                 39100000
         TM    SYL+1,1                                                  39150000
         BO    *+8                                                      39200000
         LA    1,1(1)              LONG SYLLABLE                        39250000
         LA    1,1(1)              SHORT SYLLABLE                       39300000
         STH   1,STCPTR(3,MR)                                           39350000
IRB5H    LTR   1,6                 IMITATION DFNS AVOID FOLLOWING       39400000
         BZ    IRB5G               DIRECTORY REFERENCES                 39450000
         LH    4,MFPARS(6)         FETCH NO. OF LABELS AND PARAMS       39500000
         N     4,QF15BITS          THIS IS A LOAD LOGICAL HALFWORD      39550000
         SRL   4,4                 REMOVE PARAMETER-COUNT FIELD         39600000
         LH    1,MFLCLS(6)         NUMBER OF NON-LABEL LOCALS           39650000
         LR    6,4                 NEEDED LATER FOR LABEL DEFINITION    39700000
         MH    4,MSKEL+2           SPACE REQUIRED FOR LABEL M-ENTRIES   39750000
         AR    1,6                 NON-LABEL LOCALS PLUS LOCAL LABELS   39800000
*                                  NUMBER OF STACK BYTES NEEDED FOR     39850000
         N     1,QF15BITS          FUNCTION CALL IS LOCALS X 8          39900000
         AR    1,1                                                      39950000
         SR    1,2                 LESS SPACE ALREADY STACKED           40000000
         SLA   1,2                                                      40050000
IRB5G    LA    3,STSHADOW+32(1)    PLUS FIXED AMOUNT OF FUNCTION-CALL   40100000
         ST    2,FTEMP3            INFO (INCLUDING SPACE FOR PARAMS     40150000
*                                  0 THROUGH 3)                         40200000
         LA    0,80(3,4)           COMBINE STACK AND M SPACE, ADD SLOP, 40250000
         AR    0,8                 ADD SPACE NEEDED FOR ARG M-ENTRIES,  40300000
         BAL   8,GNOSP2            AND CHECK FOR MX, PARREL OVERLAP.    40350000
         L     1,SVI               SAVE OLD VALUE OF SVI                40400000
         LR    5,1                                                      40450000
         SR    1,3                 GET NEW VALUE OF SVI AS OLD VALUE    40500000
         ST    1,SVI               LESS SPACE FOR FUNCTION CALL.        40550000
         LA    4,4                 A USEFUL CONSTANT                    40600000
         SR    0,0                 CLEAR STACK BETWEEN NEW AND OLD SVI. 40650000
         AR    1,4                                                      40700000
         LR    2,1                                                      40750000
         LA    3,STSHADOW/4+2      FIXED AREA IS SET TO ZEROES          40800000
IRB5A    ST    0,M(1)                                                   40850000
         BCT   3,IRB5B                                                  40900000
         L     0,QAVARB            WHILE PARAMS/LOCALS ARE SET TO VARBS 40950000
IRB5B    BXLE  1,4,IRB5A                                                41000000
         L     3,PATH              SAVE LOCATION IN TRANSITION DIAGRAMS 41050000
         L     7,DIASTPTR          BY STACKING PATH ON DIAGRAM STACK.   41100000
         STC   3,DIAST(7)                                               41150000
         C     7,DIASPEN           IF WE'VE ALMOST OVERFLOWN DIAST,     41200000
         BNL   SYNTDE              SIGNAL A DEPTH ERROR.                41250000
*              NOTE WELL -- THIS TEST FOR DEPTH ERROR IS PLACED SO THAT 41300000
*              THE STACK IS CLEAN, PARREL HAS NOT BEEN CHANGED YET,     41350000
*              AND THE DIAGRAM STACK HAS NOT BEEN PUSHED (THAT IS, AN   41400000
*              ERROR RECOVERY NOW WILL IGNORE WHAT WE JUST STORED.)     41450000
*              ERROR RECOVERY IS IMPOSSIBLE UNLESS THESE CONDITIONS     41500000
*              ARE SATISFIED.                                           41550000
*                                                                       41600000
*                                                                       41650000
*        STACK SPACE HAS BEEN RESERVED AND CLEARED.  LOAD IT WITH       41700000
*        FUNCTION-CALL INFORMATION.                                     41750000
         CLI   FTEMP3+3,2          HOW MANY ARGUMENTS DO WE HAVE --     41800000
         BL    IRB5D               NONE.                                41850000
         LA    3,STPARAM+16(2)                                          41900000
*              NOW RELOCATE ARGUMENTS AND REPLACE VARIABLES FOR ARGU-   41950000
*              MENTS BY EXPRESSIONS FOR ARGUMENTS.                      42000000
*                  R0 = CANONICAL UNDEFINED VARIABLE                    42050000
*                  R1 = OLD SVI + 4                                     42100000
*                  R2 = NEW SVI + 4 ( = NEW PARREL)                     42150000
*                  R3 = NEW ADDR OF LEFT ARGUMENT                       42200000
*                  R4 = 4                                               42250000
*                  R6 = NUMBER OF LABELLED LINES                        42300000
*                                                                       42350000
*              FTEMP3 IS USED TO HOLD QUAD-ON-RIGHT FLAGS AND           42400000
*              ARGUMENT COUNT.                                          42450000
         BE    IRB5E               ONE ARGUMENT.                        42500000
         BAL   7,IRB5S             FIX LEFT ARGUMENT.                   42550000
IRB5E    ST    0,M(1)              CLEAR SPOT OCCUPIED BY FN SPTR       42600000
         AR    1,4                 BUMP SOURCE AND SINK TO HANDLE       42650000
         LA    3,8(3)              RIGHT ARGUMENT.                      42700000
         BAL   7,IRB5S                                                  42750000
IRB5D    SR    1,4                 NOW PLACE BST ENTRIES FOR SHADOWED   42800000
*                                  GLOBAL NAMES INTO THE STSHADOW-      42850000
*                                  STPARAM AREA, AND PUT LOCALS IN BST. 42900000
         SR    1,4                 DFN0 DID NOT HAVE FN SPTR STACKED,   42950000
*                                  SO DROP R1 AN EXTRA WORD.            43000000
         STM   1,2,FTEMPN          PUT CODESTRING OF CURRENT LINE BACK  43050000
         L     2,PARREL            INTO DIRECTORY OF OUTER FUNCTION     43100000
         BAL   LKR,IREOSB                                               43150000
         NOP   0                   MUST BE DONE NOW SINCE FN NAME IS    43200000
         L     1,FTEMPN            NOT ACCESSIBLE IF SAME AS A PARAM    43250000
         LA    7,IRB5QH+10-(MCSORG-M)                                   43300000
         L     8,SPTR                                                   43350000
         N     8,QF24BITS          CIRCUMVENT THIS MACHINERY FOR QUAD   43400000
         BZ    IRB5X               AND OTHERS WHICH HAVE NO HEADER      43450000
         L     7,M(8)              OTHERWISE LOCATE FN DIRECTORY        43500000
*        PREPARE TO PUT ALL STATEMENT LABELS INTO THE STACK AS LOCALS.  43600000
*        WE FIND ALL CODESTRINGS FLAGGED WITH A ZLEOS SYL, RUN THE      43650000
*        FOLLOWING (LONG) SYLLABLE THROUGH THE NORMAL SHADOWING MECHAN- 43700000
*        ISM, AND ADDITIONALLY CREATE AN M-ENTRY FOR THE LOCAL HOLDING  43750000
*        THE LINE NUMBER AS AN INTEGER.                                 43800000
         LTR   6,6                 SKIP ALL THIS LABEL STUFF IF         43850000
         BZ    IRB5N               NO LABELS                            43900000
         LH    2,MFLINES(7)        POINT R2 TO THE DIRECTORY ENTRY      43950000
         BCTR  2,0                                                      44000000
         LR    10,2                                                     44050000
         SLA   2,2                 OF THE LAST LINE                     44100000
         AR    2,7                                                      44150000
IRBL3    L     7,MFCODE(2)         ADDR OF CODESTRING FOR THIS LINE     44200000
         LA    7,M+3(7)            ABSOLUTE AND CLEVERLY OFFSET         44250000
         CLI   MCSORG-M-3(7),1+2*ZLEOS WE DEPEND ON TYPEIN TO USE LEOS  44300000
         BE    IRBL2               ONLY IF A VALID LABEL EXISTS         44350000
IRBL1    S     2,QF4               DROP TO NEXT LOWER LINE NUMBER       44400000
         BCT   10,IRBL3            ALWAYS BRANCHES                      44450000
MSKEL    DC    AL4(MRHO+4-M),FL1'2,0',H'0'                              44500000
IRBL2    L     5,MX                WE KNOW SPACE EXISTS                 44550000
         LA    4,M(5)              CREATE A SCALAR INTEGER M-ENTRY      44600000
         MVC   MCOUNT-M(MRHO-MCOUNT,4),MSKEL   COUNT, TYPE, RANK        44700000
         ST    10,MRHO(5)          LINE NUMBER IS VALUE                 44750000
         O     5,QATMPCLS          NOTE THAT LABELS ARE LOCAL CONSTANTS 44800000
         ST    5,STPARAM-STSHADOW(1,MR)  LET IRB5Y POINT M-ENTRY AT STK 44850000
         LA    5,MRHO+4-M(5)       ADVANCE MX OVER NEW M-ENTRY          44900000
         ST    5,MX                                                     44950000
         BAL   LKR,IRB5Y           NOW TAKE CARE OF THE SHADOWING       45000000
         BCT   6,IRBL1             DUCK OUT AS SOON AS ALL LABELS ARE   45050000
*                                  PROCESSED                            45100000
         L     7,M(8)              RECALL FN DIRECTORY (NOTE R8 MAY     45150000
*                                  NOW POINT INTO THE STACK BY MAGIC)   45200000
IRB5N    L     7,MFCODE(7)         THEN CODESTRING FOR LINE 0           45300000
         AR    7,MR                                                     45350000
         AH    7,MCSCNT-M(7)       THEN RIGHT END OF LINE 0 (OFFSET)    45400000
IRB5X    LA    LKR,IRB5Z                                                45450000
*              THERE IS CONSIDERABLE DEPENDENCE HERE ON A SYNTACTICALLY 45500000
*              CORRECT FN HEADER -- IT MUST CONSIST OF ALTERNATING      45550000
*              'NOISE' (NON-LOCAL) SYLLABLES AND LOCAL SYLLABLES.       45600000
*              IN THE FOLLOWING,                                        45650000
*                  R1 = STACK ADDR OF SHADOW POINTER                    45700000
*                  R2 = DIRECTORY POINTER (LABEL LOCALIZATION ONLY)     45750000
*                  R3 = SYMBOL TABLE ADDR OF NAME                       45800000
*                  R4 = SYMBOL TABLE ENTRY                              45850000
*                  R5 = STACK ENTRY (PARAM MPTR OR UNDEFINED VARB)      45900000
*                  R6 = NUMBER OF LABELLED LINES (LABEL LOCALIZATION)   45950000
*                  R7 = ABS POINTER (OFFSET) TO CODESTRING              46000000
*                  R8 = STACK OR S.T. ADDR OF DFN ENTRY                 46050000
*                  R9 = STACK ADDR OF GLOBAL MPTR ( = R1 + 4)           46100000
*                  R10= REMAINING LINES IN FUNCTION                     46150000
IRB5Y    MVC   FTEMP3(2),MCSORG-M-2(7)                                  46200000
         LH    3,FTEMP3            PICK UP A LOCAL SYLLABLE             46250000
         SLA   3,2                 GET DOUBLEWORD INDEX                 46300000
         BZ    IRB5W               IGNORE PLACE-HOLDERS                 46350000
         A     3,QR13STK           MAKE IT M-RELATIVE                   46400000
         LA    9,STPARAM-STSHADOW(1)                                    46450000
         CR    3,8                 IF WE'RE ABOUT TO SHADOW THE FN NAME 46500000
         BNE   *+6                                                      46550000
         LR    8,9                 THEN MAKE FN SPTR POINT TO THE STACK 46600000
         L     4,M(3)              LOAD SHADOWED M-ENTRY POINTER        46650000
         L     5,STPARAM-STSHADOW(1,MR)  AND LOCAL VALUE'S MPTR         46700000
         ST    5,M(3)              PUT LOCAL IN SYMBOL TABLE            46750000
         ST    4,STPARAM-STSHADOW(1,MR)  AND GLOBAL MPTR INTO STACK     46800000
         LTR   4,4                                                      46850000
         BNP   IRB5M               IF SYMBOL TABLE ENTRY IS AN M-PTR,   46900000
         IC    0,M(4)              RELOCATE GLOBAL M-ENTRY TO POINT     47000000
         ST    9,M(4)              TO STACKED SHADOWED EST ENTRY        47050000
         STC   0,M(4)                                                   47100000
*                                  POINT SHADOW PTR AT BST ENTRY        47150000
IRB5M    DS    0H                                                       47200000
         ST    3,MHEAD(5)          POINT LOCAL M-ENTRY AT BST           47250000
IRB5W    O     3,QASHADOW          MARK SHADOW WITH SHADOW FLAG         47300000
         ST    3,STSHADOW-STSHADOW(1,MR)                                47350000
         S     1,QF8               ADVANCE TO NEXT STACK LOCATION       47400000
         BR    LKR                 BACK TO LABEL OR HEADER LOGIC        47450000
IRB5Z    S     7,QF3               ADVANCE TO NEXT LOCAL SYL IN HEADER  47500000
         CLI   MCSORG-M(7),1+2*ZEOS QUIT WHEN WE REACH END-OF-STATEMENT 47550000
         BE    IRB5K               SYLLABLE                             47600000
         TM    MCSORG-M(7),1       IF NOISE SYLLABLE WAS SHORT,         47650000
         BO    IRB5Y               CONTINUE                             47700000
         BCT   7,IRB5Y             OTHERWISE ADVANCE 1 MORE BYTE FIRST  47750000
*                                                                       47800000
IRB5K    L     2,FTEMPN+4          RECALL NEW VALUE OF PARREL           47850000
         LA    1,0(2,MR)                                                47900000
         MVC   STFREG(4,1),PARREL  LOAD OLD COPY OF PARREL,             47950000
         ST    8,STFNSPTR(1)       FUNCTION BST ENTRY POINTER,          48000000
         MVC   STFLAGS(1,1),FTEMP3+2   FLAGS FOR QUAD-ON-RIGHT,         48050000
         ST    2,PARREL            AND NEW VALUE OF PARREL.             48100000
         L     LKR,DIASTPTR                                             48150000
         LA    LKR,1(LKR)          BUMP DIAGRAM STACK POINTER           48200000
         ST    LKR,DIASTPTR                                             48250000
         LTR   5,8                 RE-LOCATE FUNCTION DIRECTORY         48300000
         BZ    IRS2Z               OR GO TO TYPEIN IF 'FN' IS QUAD (')  48350000
         MVI   STFNSPTR(1),X'80'   MARK FNSPTR INDIRECT                 48400000
         L     5,M(5)                                                   48450000
         LA    4,1                 SET NEW LINE NUMBER = 1 AND          48550000
         B     IRS2L               JOIN END-OF-STATEMENT ANALYSIS.      48600000
IRB5QH   DC    AL1(1+2*ZEOS,0,0,1+2*ZLARROW,0,0,0,2,0,0)  IMITATION     48650000
*                                                HEADER FOR QUAD        48700000
*                                                                       48750000
*              MOVE STACKED ARGUMENT TO PROPER POSITION IN FUNCTION     48800000
*              INFO.  CLEAR THE SPOT IT OCCUPIED IN THE STACK.  IF THE  48850000
*              ARGUMENT IS A VARIABLE, COPY ITS VALUE AND USE COPY AS   48900000
*              FUNCTION ARGUMENT.                                       48950000
*              ON ENTRY, R0 = CANONICAL UNDEFINED VARIABLE              49000000
*                        R1 = ADDRESS OF STACKED ARG                    49050000
*                        R3 = TARGET ADDRESS FOR ARG                    49100000
*                        R7 = RETURN ADDRESS                            49150000
*                        R8 = FN SYMBOL TABLE PTR OR 0                  49200000
*                                                                       49250000
IRB5S    L     5,M(1)              PICK UP STACKED ARGUMENT             49300000
         ST    0,M(1)                                                   49350000
         AR    1,4                 ALL CALLERS NEED THIS, SO WHY NOT    49400000
         LTR   5,5                 IS THIS ARGUMENT AN SPTR OR MPTR --  49450000
         BM    IRB5T               AN SPTR.  WE'LL HAVE TO COPY VALUE.  49500000
         AL    5,QAVMT             AN MPTR.  MAKE IT A VARIABLE AND     49550000
         ST    5,M(3)              PUT EST ENTRY IN PARAMETER LIST      49600000
         AR    5,MR                ABSOLUTE HEADER ADDRESS              49700000
         TM    MLIST-M(5),MLSTBIT  ARG MUST NOT BE A LIST               49750000
         BO    SYNT12                                                   49800000
         L     LKR,MHEAD-M(5)      PICK UP HEADER                       49850000
         SLR   LKR,1               RELOCATE IT                          49900000
         ALR   LKR,3               TO NEW STACK POSITION.               49950000
         ST    LKR,MHEAD-M(5)                                           50000000
         BR    7                                                        50050000
IRB5T    DS    0H                                                       50100000
         STM   0,7,FTEMPN                                               50150000
         L     5,M(5)              FIND LENGTH OF VALUE                 50200000
         L     0,MCOUNT(5)         SPACE NEEDED FOR COPY OF ARGUMENT    50300000
         L     1,MX                BUILD M-ENTRY FOR IT.                50350000
*              NOTE THAT CHECK FOR SPACE AVAILABILITY HAS BEEN DONE     50400000
*              AT IRB5G, SO WE CAN BYPASS GETSPACE CALL.                50450000
         ST    0,MCOUNT(1)                                              50500000
         AR    0,1                 OLD MX PLUS COUNT                    50550000
         ST    0,MX                IS NEW MX                            50600000
         ST    3,MHEAD(1)          POINT M-ENTRY AT STACK               50700000
         O     1,QAVARB            BUILD E.S.T. ENTRY FOR STACK         50750000
         ST    1,M(3)              POINT STACK AT NEW M-ENTRY           50800000
         LA    2,256               PREPARE TO MOVE VALUE.               50900000
         LA    6,M(1)              R6 IS ABSOLUTE SINK                  50950000
         LA    7,M(5)              R7 IS ABSOLUTE SOURCE                51050000
         L     5,MCOUNT-M(7)       R5 IS COUNT                          51100000
         S     5,QF261             DROP IT FOR MOVE LOOP                51150000
         BM    IRB5U               LOOP NOT NEEDED -- JUST 1 MVC.       51200000
         LA    3,0(7,5)            SET LIMIT FOR SOURCE POINTER         51250000
IRB5V    MVC   4(256,6),4(7)       MOVE 256 BYTES                       51300000
         AR    6,2                 UP SINK POINTER                      51350000
         BXLE  7,2,IRB5V           AND SOURCE POINTER                   51400000
IRB5U    EX    5,IRB5MV            DO TAIL END OF MOVE.                 51450000
         LM    0,7,FTEMPN          RESTORE SAVED REGISTERS              51500000
         BR    7                                                        51550000
IRB5MV   MVC   4(0,6),4(7)                                              51600000
         EJECT                                                          51650000
*                                                                       51700000
*        BASIC -- LIST TRAVERSED                                        51750000
IRB6     EQU   SYNTX                                                    51800000
*                                                                       51850000
*        BASIC -- LEFT PARENTHESIS OF LIST TRAVERSED                    51900000
IRB7     EQU   *                                                        51950000
*                                                                       52000000
*        BASIC -- LEFT PARENTHESIS TRAVERSED                            52050000
IRB14    EQU   *                                                        52100000
*                                                                       52150000
*        EXP -- LEFT PARENTHESIS OF SUBSCRIPTED EXPRESSION LEFT OF      52200000
*              OPERATOR TRAVERSED                                       52250000
IRE38    EQU   *                                                        52300000
         L     1,SVI               LOCATE TOP OF STACK                  52350000
         LA    3,0(1,MR)           ABSOLUTE                             52400000
         TM    11(3),1             WERE ANY SEMICOLONS PRESENT          52450000
         BZ    IRB7A               (I.E. WAS IT REALLY A LIST) --       52500000
         CLI   4(3),0              NO.  WAS THERE AN EXPRESSION OR      52550000
         BE    SYNT12              VARIABLE BETWEEN THE PARENS --       52600000
*                                  NO.  JUST ().  SYNTAX ERROR.         52650000
*              YES.  RELOCATE EST ENTRY FOR PARENTHESIZED EXPRESSION.   52700000
         LA    2,4                                                      52750000
         AR    1,2                 BUMP STACK POINTER                   52800000
         ST    1,SVI               TO REFLECT SHORTENED STACK.          52850000
         L     4,0(1,MR)           PICK UP EST ENTRY                    52900000
         ST    4,4(1,MR)           STORE IT IN END-OF-LIST '1' WORD     52950000
         LTR   4,4                 IF R4 IS AN EST ENTRY,               53000000
         BM    SYNTX                                                    53050000
         AL    2,0(4,MR)           FIX 1ST WORD OF M-ENTRY TO POINT AT  53150000
         ST    2,0(4,MR)           NEW LOCATION OF EST ENTRY.           53200000
         B     SYNTX                                                    53250000
*                                                                       53300000
*        STMT -- UNPARENTHESISED LIST (MIXED OUTPUT) TRAVERSED          53350000
IRS7     EQU   *                                                        53400000
*                                                                       53450000
*        BASIC -- LIST TRAVERSED                                        53500000
IRB8     EQU   SYNTX                                                    53550000
*                                                                       53600000
*              REENTRY FROM LEFT-PAREN INTERPRETATION RULE              53650000
IRB7A    EQU   *                                                        53700000
*                                                                       53750000
*        BASIC -- LEFT BRACKET OF SUBSCRIPT LIST TRAVERSED              53800000
IRB9     EQU   *                                                        53850000
*                                                                       53900000
*        EXP -- LEFT BRACKET OF OPERATOR SUBSCRIPT TRAVERSED            53950000
IRE25    EQU   *                                                        54000000
*                                                                       54050000
*        EXP -- LEFT BRACKET TRAVERSED                                  54100000
IRE27    EQU   *                                                        54150000
*                                                                       54200000
*        EXP -- LEFT BRACKET OF LHS TRAVERSED                           54250000
IRE28    EQU   *                                                        54300000
*              FORM A LIST M-ENTRY FROM CONTENTS OF STACK IN SVI+4      54350000
*              UP TO FLAG WORD (=1).                                    54400000
*              SHORT-CUT MOVE DEPENDS ON MX AND SVI BEING AT LEAST      54450000
*              12 APART.                                                54500000
         L     1,MX                LOAD SINK ADDRESS                    54550000
         L     2,SVI               LOAD SOURCE ADDRESS                  54600000
         LA    0,4                 COMMONLY USED CONSTANT               54650000
         LA    1,MLSORG-M-4(1)     OFFSET SINK PAST HEADER INFORMATION  54700000
IRB9A    AR    1,0                 BUMP SINK AND SOURCE                 54750000
         AR    2,0                 TO NEXT ITEM.                        54800000
         C     2,PARREL            SPECIAL EXIT FOR UNPARENTHESISED     54850000
         BE    IRB9C               LIST (ALWAYS ON PAREN LEVEL 0)       54900000
         L     3,M(2)              MOVE NEXT ITEM FROM STACK            54950000
         ST    3,M(1)              TO FREE STORAGE.                     55000000
         C     3,QF1               IS THE ITEM A FLAG WORD --           55050000
         BE    IRB9B               YES.  END OF MOVE OPERATION.         55100000
         BNH   IRB9A               NO.  IS IT AN EST ENTRY --           55150000
         IC    4,M(3)              HEADER RELOCATED TO POSITION IN      55250000
         ST    1,M(3)              LIST M-ENTRY.                        55300000
         STC   4,M(3)                                                   55350000
         B     IRB9A               BACK FOR NEXT ITEM.                  55400000
*              ADJUST MX AND SVI                                        55450000
*              FORM M-ENTRY HEADER FOR LIST                             55500000
IRB9C    SR    2,0                 SET R2 TO PARREL-4                   55550000
IRB9B    L     3,MX                PICK UP OLD MX, WHICH IS ADDRESS OF  55600000
*                                  M-ENTRY.                             55650000
         ST    1,MX                SET MX TO FIRST WORD PAST M-ENTRY.   55700000
         AL    3,QATMPCLS          STACK EST ENTRY POINTING TO M-ENTRY  55800000
         ST    3,M(2)                                                   55850000
         N     3,QF24BITS                                               55900000
         SR    2,0                 SET SVI TO ADDRESS PRECEDING FLAG WD 55950000
         ST    2,SVI                                                    56000000
         AL    2,IRB9Q             FLAG WORD POSITION IS EST ENTRY FOR  56100000
*                                  LIST.                                56150000
         ST    2,MHEAD(3)          POINT M-HEADER AT STACK.             56200000
         SR    1,3                 NEW MX - OLD MX                      56250000
         ST    1,MCOUNT(3)         IS BYTE COUNT OF M-ENTRY.            56300000
         LA    2,MLSORG-M          SET LIST OFFSET.                     56350000
         STH   2,MLSOS(3)                                               56400000
         SR    1,2                 SET COUNT OF LIST ELEMENTS.          56450000
         SRL   1,2                                                      56500000
         STH   1,MLSCT(3)                                               56550000
         BAL   8,GNOSPACE          ASSURE ADEQUATE SPACE BETWEEN NEW    56600000
*                                  MX AND SVI.                          56650000
         B     SYNTX                                                    56700000
IRB9Q    DC    A(MLSTBIT*(X'FFFFFF'+1)+4)                               56750000
*                                                                       56800000
*        BASIC -- SUBSCRIPTED EXPRESSION TRAVERSED                      56850000
IRB13    EQU   SYNTX                                                    56900000
*                                                                       56950000
*        BASIC -- SUBSCRIPTED QUANTITY TRAVERSED                        57000000
IRB15    EQU   *                                                        57050000
         LA    1,1                 SET UP FOR INDEX FETCH               57100000
         ICALL INDEX                                                    57150000
         B     SYNTX                                                    57200000
*                                                                       57250000
*        EXP -- RIGHTMOST BASIC TRAVERSED                               57300000
IRE1     EQU   SYNTX                                                    57350000
*                                                                       57400000
*        EXP -- UNSUBSCRIPTED OPERATOR TRAVERSED                        57450000
IRE2     EQU   *                                                        57500000
*                                                                       57550000
*        EXP -- UNSUBSCRIPTED SLASH/BACKSLASH TRAVERSED                 57600000
IRE3     EQU   *                                                        57650000
         SR    1,1                                                      57700000
         BAL   8,PUSH              FIRST STACK A 'NO SUBSCRIPT' FLAG    57750000
*                                                                       57800000
*        EXP -- SUBSCRIPTED OPERATOR TRAVERSED                          57850000
IRE29    EQU   *                                                        57900000
*                                                                       57950000
*        EXP -- SUBSCRIPTED SLASH/BACKSLASH TRAVERSED                   58000000
IRE30    EQU   *                                                        58050000
IRE45A   EQU   *                   REENTRY AFTER RELOCATING SUBSCRIPT   58100000
*                                  AT IRE44 OR IRE45                    58150000
         BAL   8,PSHOP             STACK OPERATOR NUMBER                58200000
         B     SYNTX                                                    58250000
*                                                                       58300000
*        EXP -- LEFT OPERATOR OF MATRIX PRODUCT TRAVERSED               58350000
IRE40    EQU   *                                                        58400000
*                                                                       58450000
*        EXP -- NULL OF MATRIX PRODUCT TRAVERSED                        58500000
IRE42    EQU   *                                                        58550000
         SR    1,1                                                      58600000
         IC    1,SYL+1             PICK UP THE OPERATOR                 58650000
         L     2,SVI                                                    58700000
         STC   1,6(2,MR)           PUT IT IN STACK NEXT TO RT OPERATOR  58750000
         B     SYNTX                                                    58800000
*                                                                       58850000
*        EXP -- LEFT ARROW TRAVERSED                                    58900000
IRE5     EQU   SYNTX                                                    58950000
*                                                                       59000000
*        EXP -- ENTIRE EXPRESSION TRAVERSED                             59050000
IRE7     EQU   SYNTX                                                    59100000
*                                                                       59150000
*        EXP -- BASIC LEFT OF OPERATOR OR DEFINED FUNCTION TRAVERSED    59200000
IRE8     EQU   *                                                        59250000
         L     5,SVI                                                    59300000
         L     1,M+8(5)            LOOK AT OPERATOR                     59350000
         LTR   1,1                 IS IT OP OR FUNCTION --              59400000
         BM    IRE8A               DEFINED FUNCTION.                    59450000
*                                                                       59500000
*        EXP -- BASIC PRECEDING MATRIX PRODUCT TRAVERSED                59550000
IRE41    EQU   *                                                        59600000
         ICALL DODOP               OP. EXECUTE DYADIC OPERATOR.         59650000
         B     SYNTX                                                    59700000
*                                                                       59750000
*        EXP -- 'EMPTY' IMPLYING MONADIC OPERATOR OR DEFINED FUNCTION   59800000
*              TRAVERSED                                                59850000
IRE13    EQU   *                                                        59900000
IRE33A   EQU   *                   REENTRY FOR MONADIC OP OR DFN        59950000
*                                  'DISCOVERED' FOLLOWING SUBSCRIPTED   60000000
*                                  OP, SLASH, OR BACKSLASH              60050000
         L     5,SVI                                                    60100000
         L     1,M+4(5)            IS THIS OPERATOR OR DEFINED FUN --   60150000
         LTR   1,1                                                      60200000
         BM    IRE13A              DEFINED FUNCTION.                    60250000
IDOMOP   ICALL DOMOP               OP. EXECUTE MONADIC OPERATOR         60300000
         B     SYNTX                                                    60350000
*                                                                       60400000
*        EXP -- OPERATOR OF REDUCTION TRAVERSED                         60450000
IRE14    EQU   *                                                        60500000
         SR    1,1                                                      60550000
         L     2,SVI                                                    60600000
         IC    1,7(2,MR)           MOVE SLASH TO LEFT                   60650000
         STC   1,6(2,MR)                                                60700000
         IC    1,SYL+1             PICK UP THE OPERATOR                 60750000
         STC   1,7(2,MR)           PUT IT WHERE SLASH WAS               60800000
         B     IDOMOP                                                   60850000
*                                                                       60900000
*        EXP -- BASIC LEFT OF SLASH/BACKSLASH TRAVERSED                 60950000
IRE15    EQU   *                                                        61000000
         ICALL SELECT                                                   61050000
         B     SYNTX                                                    61100000
         SPACE 3                                                        61150000
PSHOP    SR    1,1                                                      61200000
         IC    1,SYL+1             ASSUME SHORT SYLLABLE                61250000
         TM    SYL+1,1                                                  61300000
         BO    PUSH                                                     61350000
         L     2,SPTR              NO, LONG SYL.  GET OP NO FROM SYMBOL 61400000
         LH    1,2(2,MR)           TABLE ENTRY.                         61450000
         B     PUSH                                                     61500000
         EJECT                                                          61550000
*                                                                       61600000
*        EXP -- SPECIFICATION OF UNSUBSCRIPTED VARIABLE TRAVERSED       61650000
IRE18    EQU   *                                                        61700000
         BAL   LKR,CSTSUB          SET 'COMPLETE STATEMENT' BIT         61750000
         NOP   0                                                        61800000
*              ON RETURN FROM CSTSUB,                                   61850000
*              R4  = SVI                                                61900000
*              R6 = PARREL (ABSOLUTE)                                   61950000
         L     1,M+4(4)            R1 IS RHS STACK ENTRY                62000000
         TM    SYL+1,1             WAS SYLLABLE SHORT OR LONG --        62050000
         BO    IRE18Q              SHORT.  THIS IS A DISPLAY.           62100000
*                                                                       62150000
*              POSSIBLE CASES IN UNSUBSCRIPTED SPECIFICATION            62200000
*        AND ACTIONS TAKEN.  IF RHS IS EXPRESSION AND THIS IS COMPLETE  62250000
*        STATEMENT, TOP OF STACK AFTER SPECIFICATION IS POINTER TO LHS. 62300000
*        OTHERWISE, IT IS POINTER TO RHS.                               62350000
*                                                                       62400000
*                LHS UNDEFINED     LHS - RHS         LHS - RHS          62450000
*                                  LENGTHS EQUAL     LENGTHS UNEQUAL    62500000
*              ........................................................ 62550000
*RHS IS VARB   .                                                      . 62600000
* OR, NESTED   .                                     GETSPACE DIF (>0). 62650000
* SPECIFICATION.   GETSPACE        COPY RHS VALUE    MARK LHS GARBAGE . 62700000
*              .   COPY RHS VALUE                    GETSPACE RHS LGTH. 62750000
*              .                                     COPY RHS VALUE   . 62800000
*              .                                                      . 62850000
*RHS IS EXPN,  .   CHECK FOR LIST  CHECK FOR LIST    CHECK FOR LIST   . 62900000
* NOT NESTED SP.   LINK LHS TO     MARK OLD LHS GAR  MARK OLD LHS GAR . 62950000
*              .       RHS VALUE       BAGE              BAGE         . 63000000
*              .                   LINK LHS TO RHS   LINK LHS TO RHS  . 63050000
*              .                       VALUE             VALUE        . 63100000
*              ........................................................ 63150000
*                                                                       63200000
         L     2,SPTR              R2 IS LEFT-HAND-SIDE                 63250000
         LTR   3,1                 IS RHS AN EXPRESSION OR A VARIABLE - 63300000
         L     1,M(2)              R1 IS SYMBOL TABLE ENTRY OF LHS      63350000
         BP    IRE18A              EXPRESSION.                          63400000
*              REENTRY FOR NESTED SPECIFICATION OF VARB BY EXPN         63500000
IRE18C   L     4,M(3)              GET MPTR OF RHS                      63550000
         N     1,QF24BITS          MASK OFF CLASS ETC OF LHS            63650000
         BZ    IRE18D              IS LHS PRESENTLY UNDEFINED --        63700000
         L     7,MCOUNT(4)         NO.                                  63750000
         S     7,MCOUNT(1)         ARE LHS AND RHS OF THE SAME LENGTH,  63800000
*                                  SO THAT WE CAN COPY RHS VALUE INTO   63850000
*                                  SPACE CURRENTLY OCCUPIED BY LHS --   63900000
         BE    IRE18B              YES.                                 63950000
         BM    IRE18L              WE NEED NEW SPACE FOR LHS            64000000
*                                  NO PROBLEM IF NEW LENGTH SMALLER     64050000
         LA    0,40(7)             IF LARGER, ASSURE THAT THE DIFFERENC 64100000
         BAL   8,GNOSP2            EXISTS BEFORE MARKING OLD LHS GARBAG 64150000
         L     4,M(3)              WE MAY HAVE GARBAGE-COLLECTED.       64200000
         L     1,M(2)              RECALL LHS AND RHS M-POINTERS        64250000
         LA    1,0(1)              NO HIGH-ORDER GARBAGE FOR MKG        64300000
IRE18L   MKG   1                   MARK SHORTER OR LONGER LHS GARBAGE   64400000
IRE18D   L     1,MCOUNT(4)         ASK FOR LENGTH OF RHS                64450000
         ICALL GETSPACE            NOTE THAT WE ASSUME R2 NE 0          64500000
         IC    0,M(2)              CONNECT LHS SYMBOL TABLE ENTRY TO    64550000
         ST    1,M(2)              ITS NEW M-ENTRY.                     64600000
         STC   0,M(2)                                                   64650000
         ST    2,MHEAD(1)          POINT M-ENTRY BACK TO LHS.           64750000
         L     4,M(3)              RECALL THE RHS MPTR                  64800000
*              COPY VALUE OF RHS INTO M-ENTRY OF LHS                    64850000
*                                  R1 IS LHS MPTR                       64900000
*                                  R4 IS RHS MPTR                       64950000
*                                                                       65000000
*                                                                       65050000
IRE18B   LA    4,0(4,MR)           R4 IS ABSOLUTE SOURCE ADDRESS        65100000
         AR    1,MR                R1 IS ABSOLUTE SINK ADDRESS          65200000
         LA    2,256               R2 IS INCREMENT FOR BXLE             65250000
         L     5,MCOUNT-M(4)       R5 IS FULL COUNT OF SOURCE           65300000
         S     5,QF261             DROP IT BY 256 FOR MOVE LOOP AD-     65400000
*                                  JUSTMENT, 1 FOR MVC ADJUSTMENT,      65450000
*                                  AND 4 TO AVOID COPYING M-HEADER.     65500000
         BM    IRE18P              DO WE AVOID THE LONG MOVE ALTOGETHER 65550000
         LA    3,0(4,5)            NO.  R3 IS LIMIT FOR BXLE.           65600000
IRE18E   MVC   4(256,1),4(4)       THE MOVE LOOP.                       65650000
         AR    1,2                 MOVE 256 BYTES, UPDATE SOURCE AND    65700000
         BXLE  4,2,IRE18E          SINK, AND REPEAT UNTIL SHORT MVC.    65750000
IRE18P   EX    5,IRE18M            FINISH OFF THE MOVE.                 65800000
         B     IRE18T              DONE EXCEPT TO CHECK FOR DFN TRACE   65850000
IRE18M   MVC   4(0,1),4(4)                                              65900000
*                                                                       65950000
*                                                                       66000000
IRE18A   DS    0H                                                       66050000
         LA    5,0(3,MR)                                                66100000
         TM    MLIST-M(5),MLSTBIT  IS EXPRESSION A LIST --              66150000
         BNZ   SYNT12              YES. NO SPECIFICATION BY LISTS.  G01 66200000
         TM    STFLAGS(6),STSTBIT  IF NOT COMPLETE STATEMENT,           66250000
         BNZ   IRE18K              (IT IS)                              66300000
         LA    3,4(4)              MUST COPY VALUE AND LEAVE TOS=EXPN.  66350000
         B     IRE18C                                                   66400000
IRE18K   O     2,QFBIT0            MAKE TOS AN INDIRECT ENTRY           66450000
         ST    2,M+4(4)            FOR LHS.                             66500000
         N     1,QF24BITS          IS LHS DEFINED --                    66600000
         BZ    IRE18F              NO.                                  66650000
         MKG   1                   YES.  MARK PREVIOUS VALUE GARBAGE.   66700000
IRE18F   IC    1,M(2)              LINK LHS SYMBOL TABLE ENTRY TO       66750000
         ST    3,M(2)              VALUE OF EXPRESSION                  66800000
         STC   1,M(2)                                                   66850000
         IC    1,MHEAD(3)          AND VICE VERSA.                      66900000
         ST    2,MHEAD(3)                                               66950000
         STC   1,MHEAD(3)                                               67000000
IRE18T   EQU   *                                                        67050000
         B     SYNTX                                                    67100000
IRE51M   EQU   *                                                        67150000
         L     7,M(3)              THEN POINTER TO FUNCTION DIRECTORY   67200000
         LA    3,0(7,MR)           PREPARE TO ERASE ANY TRACE, STOP BIT 67300000
         TM    MHEAD-M(3),MFLKBIT  TRACE OR STOP OF PROTECTED FUNCTION  67350000
         BO    SYNTX               NOT ALLOWED                          67400000
         LH    1,MLSCT-M(3)        SAVE STATEMENT COUNT                 67450000
         ST    1,FTEMP1                                                 67500000
IRE20D   EX    2,IRE20N            WHICH MAY CURRENTLY BE ON.           67550000
         LA    3,4(3)              LOOP STARTS ERASING ON STATEMENT     67600000
*                                  0.  A DFN IS GUARANTEED TO HAVE AT   67650000
*                                  LEAST ONE LINE, SO LEADING TEST      67700000
*                                  ISN'T NEEDED.                        67750000
         BCT   1,IRE20D                                                 67800000
         LCR   5,2                 DECOMPLEMENT TR/PS BIT               67850000
         BCTR  5,0                                                      67900000
         L     3,SVI                                                    67950000
         L     3,M+4(3)                                                 68000000
         LTR   1,3                 NOW LOOK AT RHS.                     68050000
         BP    IRE20B                                                   68100000
         L     1,M(1)                                                   68200000
IRE20B   DS    0H                                                       68250000
         LR    3,1                 COMPUTE BASE ADDRESS OF RHS DATA     68300000
         AH    3,MRANK(1)          AS MPTR PLUS 4*RANK                  68350000
         LA    3,MRHO-M(3)         PLUS OFFSET OF RANK VECTOR, PLUS M   68400000
         ST    3,FTEMPN+4                                               68450000
         SR    2,2                                                      68500000
         IC    2,MTYPE(1)          SAVE RHS TYPE                        68550000
         ST    2,FTEMPN                                                 68600000
         ICALL XRHO                FIND NUMBER OF COMPONENTS IN RHS     68650000
         LR    6,1                 AND LEAVE THAT IN R6.                68700000
IRE20A   LM    3,4,FTEMPN          RELOAD BASE ADDRESS, TYPE,           68750000
         BCTR  6,0                                                      68800000
         LTR   2,6                 AND INDEX OF RHS                     68850000
         BM    SYNTX               HAVE ALL COMPONENTS BEEN USED --     68900000
         ICALL FETCHINT            NO.  FETCH THE NEXT.                 68950000
         LR    1,0                                                      69000000
         C     1,FTEMP1            IS IT WITHIN RANGE OF LINE NUMBERS - 69050000
         BNL   IRE20A              NO.  TOO BIG.                        69100000
         SLA   1,2                 MAKE IT A WORD INDEX                 69150000
         BNH   IRE20A              AND TEST FOR NEGATIVE OR ZERO        69200000
         AR    1,MR                IN RANGE.  MAKE IT ABSOLUTE          69250000
         AR    1,7                 POINTER TO CODESTRING ENTRY          69300000
         EX    5,IRE20R            AND TURN ON TRACE OR STOP.           69350000
         B     IRE20A              BACK FOR THE NEXT COMPONENT.         69400000
IRE18Q   ICALL GOUT                QUAD SPECIFIED BY RHS                69450000
         B     SYNTX                                                    69500000
IRE20N   NI    MFCODE-M(3),0       EXECUTED TRACE- OR STOP-BIT CLEARER  69550000
IRE20R   OI    MFCODE-M(1),0       EXECUTED TRACE OR STOP BIT SETTER    69600000
*                                                                       69650000
*        EXP -- DFN OR DFN0 LEFT OF SPECIFICATION TRAVERSED             69700000
IRE50    EQU   *                                                        69750000
*        TRACE (OR STOP) IS DETECTED BY THE OTHERWISE ILLEGAL           69800000
*        SPECIFICATION OF A DFN OR DFN0.                                69850000
         MVC   FTEMP1,SPTR         JUST SAVE SYMBOL TABLE ADDR OF DFN   69900000
         B     SYNTX                                                    69950000
*                                                                       70000000
*        EXP -- TRACE OR PROGRAMMED STOP LEFT OF DFN OR DFN0 TRAVERSED  70050000
IRE51    EQU   *                                                        70100000
         BAL   LKR,CSTSUB                                               70150000
         NOP   0                                                        70200000
         L     3,FTEMP1            RECALL SPTR OF FUNCTION              70250000
         TRT   SYL+1(1),IRE51TB    PICK UP 8-BIT MASK FOR TRACE OR STOP 70300000
         B     IRE51M                                                   70350000
IRE51TB  EQU   *-2*ZTDELTA-1                                            70400000
         DC    AL1(255-STTRBIT,0,255-STPSBIT)                           70450000
         DC    0H'0'               GET LOCATION CTR ALIGNED FOR EQU     70500000
*                                                                       70550000
*        EXP -- LIST AS OPERATOR SUBSCRIPT TRAVERSED                    70600000
IRE21    EQU   SYNTX                                                    70650000
*                                                                       70700000
*        EXP -- SUBSCRIPTED OPERAND LEFT OF OPERATOR OR DFN TRAVERSED   70750000
IRE22    EQU   *                                                        70800000
         LA    1,1                                                      70850000
         ICALL INDEX               PERFORM THE INDEXING                 70900000
         B     IRE8                AND JOIN OPND OP OPND CODE           70950000
*                                                                       71000000
*        EXP -- LIST AS SUBSCRIPT OF OPERAND LEFT OF OPERATOR TRAVERSED 71050000
IRE23    EQU   SYNTX                                                    71100000
*                                                                       71150000
*        EXP -- LIST AS SUBSCRIPT OF LHS TRAVERSED                      71200000
IRE24    EQU   SYNTX                                                    71250000
*                                                                       71300000
*        EXP -- SUBSCRIPTED OPERATOR PRECEDING MONADIC OPERATOR OR      71350000
*              DEFINED FUNCTION TRAVERSED                               71400000
IRE33    EQU   *                                                        71450000
*                                                                       71500000
*        EXP -- SUBSCRIPTED SLASH/BACKSLASH PRECEDING MONADIC OPERATOR  71550000
*              OR DEFINED FUNCTION TRAVERSED                            71600000
IRE34    EQU   *                                                        71650000
         LM    2,3,SVI ,PARREL     WE MUST BACKTRACK ENOUGH TO EXECUTE  71700000
         L     1,4(2,MR)           THE MONADIC OP.  TOWARD THIS END,    71750000
         ST    1,STPARAM(3,MR)     MOVE STACK ENTRY FOR SUBSCRIPT TO    71800000
         LA    4,STPARAM-4(3)      RELOCATE M-ENTRY TO POINT TO THIS    71900000
         SR    4,2                                                      71950000
         A     4,MHEAD(1)          NEW STACK LOCATION.                  72000000
         ST    4,MHEAD(1)                                               72050000
         LA    2,4(2)              BUMP SVI .                           72100000
         ST    2,SVI                                                    72150000
         B     IRE33A              NOW EXECUTE THE WHATEVER-IT-WAS.     72200000
*                                                                       72250000
*        EXP -- SUBSCRIPTED VARIABLE LEFT OF LEFT ARROW TRAVERSED       72300000
IRE36    EQU   *                                                        72350000
         TM    SYL+1,1             SPECIFICATION OF SUBSCRIPTED QUAD    72400000
         BO    SYNT12              OR QUAD PRIME IS MEANINGLESS         72450000
         L     1,SPTR              STACK INDEX-SPECIFYEE                72500000
         O     1,QFBIT0                 INDIRECT POINTER                72550000
         BAL   8,PUSH                                                   72600000
         SR    1,1                 JUST SET UP FOR AN INDEX STORE       72650000
         ICALL INDEX                                                    72700000
         BAL   LKR,CSTSUB          CHECK FOR COMPLETE STATEMENT         72750000
         B     SYNTX                                                    72800000
         B     SYNTX                                                    72850000
*                                                                       72900000
*        EXP -- SUBSCRIPTED PARENTHESIZED EXPRESSION LEFT OF OPERATOR   72950000
*              TRAVERSED                                                73000000
IRE37    EQU   SYNTX                                                    73050000
*                                                                       73100000
*        EXP -- PERIOD OF MATRIX PRODUCT TRAVERSED                      73150000
IRE39    EQU   *                                                        73200000
         L     2,SVI                                                    73250000
         L     1,M+4(2)            GIVE SYNTAX ERROR IF PREVIOUS OP G01 73300000
         LTR   1,1                                                      73350000
         BP    SYNTX               WAS REALLY A DEFINED FUNCTION.       73400000
         B     SYNT12              SYNTAX ERROR                     G01 73450000
*                                                                       73500000
*        EXP -- SUBSCRIPTED OPERATOR PRECEDING MONADIC OP OR MONADIC    73550000
*              DEFINED FUNCTION TRAVERSED                               73600000
IRE44    EQU   *                                                        73650000
*                                                                       73700000
*        EXP -- SUBSCRIPTED SLASH/BACKSLASH PRECEDING MONADIC OPERATOR  73750000
*              OR MONADIC DEFINED FUNCTION TRAVERSED                    73800000
IRE45    EQU   *                                                        73850000
         LM    2,3,SVI ,PARREL     UNDO WORK AT IRE34                   73900000
         L     1,STPARAM(3,MR)     BY MOVING 'PARAM 0' BACK WHERE IT    73950000
         ST    1,0(2,MR)           BELONGS.                             74000000
         L     4,MHEAD(1)                                               74100000
         AR    4,2                                                      74150000
         LA    0,STPARAM(3)        RELOCATE SUBSCRIPT LIST M-ENTRY      74200000
         SR    4,0                 BY SUBTRACTING (STPARAM+PARREL)-SVI  74250000
         ST    4,MHEAD(1)                                               74300000
         SR    0,0                                                      74350000
         ST    0,STPARAM(3,MR)     ERASE M-POINTER FROM 'PARAM 0' WORD  74400000
         S     2,QF4               DROP SVI PAST SUBSCRIPT ON STACK     74450000
         ST    2,SVI                                                    74500000
         B     IRE45A              JOIN OP AND SLASH/BACKSLASH CODE     74550000
*                                                                       74600000
*                                                                       74650000
*                                                                       74700000
*                                                                       74750000
CSTSUB   LM    1,2,SVI ,PARREL     MUCH OF THIS IS FOR IRE18'S          74800000
         LR    4,1                 CONVENIENCE                          74850000
         LA    6,0(2,MR)           ABSOLUTE PARREL                      74900000
         LA    5,8(1)              CLEARLY NOT COMPLETE STATEMENT       74950000
         CR    5,2                 IF MORE THAN A SINGLE VALUE          75000000
         BNE   CSTSB2              IS STACKED                           75050000
         OI    STFLAGS(6),STSTBIT  SET 'COMPLETE STMT' BIT              75100000
         L     5,STCODE(6)         BASE ADDR OF CODESTRING              75150000
         AH    5,STCPTR(6)         PLUS CURRENT BYTE COUNT              75200000
         AR    5,MR                ABSOLUTE                             75300000
         CLI   MCSORG-M-1(5),ZEOS*2+1  MAY BE A REAL EOS SYLLABLE       75350000
         BE    4(LKR)                                                   75400000
         CLI   MCSORG-M-1(5),ZFCOLON*2+1 OR FAKE COLON AFTER LABEL      75450000
         BE    4(LKR)                                                   75500000
CSTSB2   NI    STFLAGS(6),255-STSTBIT                                   75550000
         BR    LKR                 RESET COMPLETE STATEMENT BIT         75600000
*                                                                       75650000
*        PUSH  THE CONTENTS OF R1 ONTO STACK, POSSIBLY CAUSING A GAR-   75700000
*              BAGE COLLECTION.  SVI POINTS TO FIRST FREE LOCATION, SO  75750000
*              PUSH CAN STACK R1, DECREMENT SVI, AND THEN TEST.         75800000
PUSH     L     2,SVI               LOAD STACK INDEX                     75850000
         ST    1,0(2,MR)           STORE R1 ON TOP OF STACK             75900000
         S     2,QF4               DROP SVI BY 1 WORD                   75950000
         ST    2,SVI                                                    76000000
*        GET NO SPACE, BUT MAKE SURE THAT ADEQUATE SPACING EXISTS       76050000
*              BETWEEN MX AND SVI.                                      76100000
GNOSPACE LA    0,40                LEAVE 40 BYTES SLOP, LIKE GETSPACE   76150000
GNOSP2   ST    0,FTEMP2            SAVE SLOP                            76200000
GNOSP1   S     0,SVI                                                    76250000
         A     0,MX                                                     76300000
         BCR   4,8                 DO WE HAVE THAT MUCH SLOP --         76350000
         ICALL GCOL                AH, NO.  DO A GARBAGE COLLECTION.    76400000
         L     0,FTEMP2            RECALL SLOP                          76450000
         B     GNOSP1              THIS TIME WE'D BETTER HAVE SLOP.     76500000
         LTORG                                                          76550000
PATCH    DS    32H                 PATCH AREA                           76600000
DIAG     DS    128H                                                     76650000
DIIR     DS    128Y                                                     76700000
         ORG   DIAG+TERMSYM+2                                           76750000
         DS    0H                                                       76800000
STMTSTMT EQU   *-DIAG                                                   76850000
         DC    AL1(0,STMT)                                              76900000
STMT     PATH  (EXP,STM1,IRS1)                                          76950000
         PATH  (RARROW,STM2,IRS5),0                                     77000000
STM1     PATH  (EOS,0,IRS2)                                             77050000
         PATH  (RARROW,STM2,IRS3)                                       77100000
         PATH  (SEMIC,STM3,IRS6),0 GLITCH FOR MIXED OUTPUT W/O PARENS   77150000
STM3     PATH  (LIST,STM2,IRS7),0                                       77200000
STM2     PATH  (EOS,0,IRS4),0                                           77250000
NONSTMT  EQU   *-DIAG                                                   77300000
LIST     PATH  (SEMIC,LIST,IRL1)                                        77350000
         PATH  (EXP,LIS1,IRL2)                                          77400000
         PATH  (TERMSYM,0,IRL3)                                         77450000
LIS1     PATH  (SEMIC,LIST,IRL4)                                        77500000
         PATH  (TERMSYM,0,IRL5)                                         77550000
BASIC    PATH  (VARB,0,IRB1)                                            77600000
         PATH  (CONST,0,IRB2)                                           77650000
         PATH  (RPAR,BAS1,IRB3)                                         77700000
         PATH  (RBR,BAS2,IRB4)                                          77750000
         PATH  (DFN0,0,IRB5),0                                          77800000
BAS1     PATH  (LIST,BAS3,IRB6),0                                       77850000
BAS3     PATH  (LPAR,0,IRB7),0                                          77900000
BAS2     PATH  (LIST,BAS4,IRB8),0                                       77950000
BAS4     PATH  (LBR,BAS5,IRB9),0                                        78000000
BAS5     PATH  (VARB,BAS8,IRB10)                                        78050000
         PATH  (RPAR,BAS6,IRB11)                                        78100000
         PATH  (CONST,BAS8,IRB16)                                       78150000
         PATH  (DFN0,BAS8,IRB12),0                                      78200000
BAS6     PATH  (EXP,BAS7,IRB13),0                                       78250000
BAS7     PATH  (LPAR,BAS8,IRB14),0                                      78300000
BAS8     PATH  (TERMSYM,0,IRB15)                                        78350000
EXP      PATH  (BASIC,EXP1,IRE1),0                                      78400000
EXP1     PATH  (OP,EXP2,IRE2)                                           78450000
         PATH  (SLSH,EXP3,IRE3)                                         78500000
         PATH  (DFN,EXP2,IRE4)                                          78550000
         PATH  (LARROW,EXP5,IRE5)                                       78600000
         PATH  (RBR,EXP6,IRE6)                                          78650000
         PATH  (TERMSYM,0,IRE7)                                         78700000
EXP2     PATH  (RBR,EXP8,IRE12)                                         78750000
         PATH  (BASIC,EXP1,IRE8)                                        78800000
         PATH  (PER,EXP19,IRE39)                                        78850000
         PATH  (TERMSYM,EXP1,IRE13)                                     78900000
EXP3     PATH  (OP,EXP1,IRE14)                                          78950000
         PATH  (BASIC,EXP1,IRE15),0                                     79000000
EXP5     PATH  (VARB,EXP1,IRE18)                                        79050000
         PATH  (RBR,EXP9,IRE19)                                         79100000
*        GLITCH TO ALLOW TRACE AND STOP VECTORS                         79150000
         PATH  (DFN,EXP21,IRE50)                                        79200000
         PATH  (DFN0,EXP21,IRE50),0                                     79250000
EXP21    PATH  (DFNT,EXP1,IRE51),0                                      79300000
*        END OF GLITCH                                                  79350000
EXP6     PATH  (LIST,EXP10,IRE21),0                                     79400000
EXP7     PATH  (TERMSYM,EXP1,IRE22)                                     79450000
EXP8     PATH  (LIST,EXP12,IRE23),0                                     79500000
EXP9     PATH  (LIST,EXP13,IRE24),0                                     79550000
EXP10    PATH  (LBR,EXP14,IRE25),0                                      79600000
EXP12    PATH  (LBR,EXP15,IRE27),0                                      79650000
EXP13    PATH  (LBR,EXP16,IRE28),0                                      79700000
EXP14    PATH  (OP,EXP2,IRE29)                                          79750000
         PATH  (SLSH,EXP3,IRE30),0                                      79800000
EXP15    PATH  (VARB,EXP7,IRE31)                                        79850000
         PATH  (RPAR,EXP17,IRE32)                                       79900000
         PATH  (CONST,EXP7,IRE43)                                       79950000
         PATH  (DFN0,EXP7,IRE35)                                        80000000
         PATH  (TERMSYM,EXP22,IRE33),0                                  80050000
EXP16    PATH  (VARB,EXP1,IRE36),0                                      80100000
EXP17    PATH  (EXP,EXP18,IRE37),0                                      80150000
EXP18    PATH  (LPAR,EXP7,IRE38),0                                      80200000
EXP19    PATH  (OP,EXP20,IRE40)                                         80250000
         PATH  (NULL,EXP20,IRE42),0                                     80300000
EXP20    PATH  (BASIC,EXP1,IRE41),0                                     80350000
EXP22    PATH  (OP,EXP2,IRE44)                                          80400000
         PATH  (SLSH,EXP3,IRE45),0                                      80450000
*                                                                       80500000
         ORG   DIIR+256                                                 80550000
SYLCLASS EQU   *                                                        80600000
         DC    256X'FF'            (256 MIN 2 TIMES ZLENGTH)X'FF'  2538 80650000
LARROW   SYLC  LARROW                                                   80700000
FPER     SYLC  PER                 IMITATION PERIOD, NECESSARY BECAUSE  80750000
*                                  VALUE OF REAL PERIOD IS GTR 127.     80800000
FCOLON   SYLC  EOS                 SAME COMMENT                         80850000
RARROW   SYLC  RARROW                                                   80900000
LPAR     SYLC  LPAR                                                     80950000
RPAR     SYLC  RPAR                                                     81000000
LBR      SYLC  LBR                                                      81050000
RBR      SYLC  RBR                                                      81100000
QUAD     SYLC  QUAD                                                     81150000
QUADP    SYLC  QUAD                                                     81200000
EOS      SYLC  EOS                                                      81250000
SEMIC    SYLC  SEMIC                                                    81300000
PLUS     SYLC  OP                                                       81350000
MINUS    SYLC  OP                                                       81400000
TIMES    SYLC  OP                                                       81450000
DIV      SYLC  OP                                                       81500000
STAR     SYLC  OP                                                       81550000
MAX      SYLC  OP                                                       81600000
MIN      SYLC  OP                                                       81650000
MOD      SYLC  OP                                                       81700000
AND      SYLC  OP                                                       81750000
OR       SYLC  OP                                                       81800000
NOT      SYLC  OP                                                       81850000
LT       SYLC  OP                                                       81900000
LE       SYLC  OP                                                       81950000
EQ       SYLC  OP                                                       82000000
GE       SYLC  OP                                                       82050000
GT       SYLC  OP                                                       82100000
NE       SYLC  OP                                                       82150000
QUERY    SYLC  OP                                                       82200000
SHRIEK   SYLC  OP                                                       82250000
CIRCLE   SYLC  OP                                                       82300000
EPS      SYLC  OP                                                       82350000
IOTA     SYLC  OP                                                       82400000
RHO      SYLC  OP                                                       82450000
UARROW   SYLC  OP                                                       82500000
DARROW   SYLC  OP                                                       82550000
REV      SYLC  OP                                                       82600000
COLREV   SYLC  OP                                                       82650000
BASE     SYLC  OP                                                       82700000
REP      SYLC  OP                                                       82750000
COMMA    SYLC  OP                                                       82800000
UPGRADE  SYLC  OP                                                       82850000
DNGRADE  SYLC  OP                                                       82900000
DOMINO   SYLC  OP                                                       82950000
TDELTA   SYLC  DFNT                                                     83000000
SDELTA   SYLC  DFNT                                                     83050000
NULL     SYLC  NULL                                                     83100000
TRAN     SYLC  OP                                                       83150000
HIST     SYLC  OP                                                       83200000
LOG      SYLC  OP                                                       83250000
NAND     SYLC  OP                                                       83300000
NOR      SYLC  OP                                                       83350000
SLASH    SYLC  SLSH                                                     83400000
BSLASH   SYLC  SLSH                                                     83450000
COLSLSH  SYLC  SLSH                                                     83500000
COLBSLH  SYLC  SLSH                                                     83550000
ECONST   SYLC  CONST                                                    83600000
BCONST   SYLC  CONST                                                    83650000
ICONST   SYLC  CONST                                                    83700000
FCONST   SYLC  CONST                                                    83750000
CCONST   SYLC  CONST                                                    83800000
         ORG                                                            83850000
LOCALS   DSECT                                                          83900000
IRCPTR   DS    F                   M-RELATIVE CODE POINTER FOR CONST IR 83950000
FTEMP1   DS    F                                                        84000000
FTEMP2   DS    F                                                        84050000
FTEMP3   DS    F                                                        84100000
FTEMPN   DS    8F                                                       84150000
BRVAL    DS    F                   VALUE OF BRANCH EXPRESSION IF LAST   84200000
*                                  STATEMENT WAS A BRANCH               84250000
HTEMP    DS    H                                                        84300000
LEND     EQU   *                                                        84350000
         END                                                            84400000
./  ADD    NAME=APLSTAKE
TAKE     TITLE 'A R R O W S  --  T A K E   A N D   D R O P    05/11/70' 00200000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00400000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00600000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00800000
ARROWS   CSECT                                                          01000000
         PRINT OFF       APLDEFN, ZSYMBOLS, OPSECT                      01400000
         COPY  APLDEFN                                                  01600000
         COPY  ZSYMBOLS                                                 01800000
         COPY  OPSECT                                                   02000000
         TITLE 'A R R O W S  --  T A K E   A N D   D R O P    05/11/70' 02200000
ARROWS   CSECT                                                          02400000
         PRINT ON,NOGEN                                                 02600000
         EXTRN ERROR                                                    02800000
         EXTRN FETCHINT                                                 03000000
         EXTRN OPSPACE                                                  03200000
         ENTRY EXTAKE                                                   03400000
         ENTRY LJWMOVE                                                  03600000
         ENTRY EXLEAVE                                                  03800000
R1       EQU   1                   HOLDS RESULT OF FETCH.               04000000
R2       EQU   2                                                        04200000
I        EQU   R2                  INDEX FOR LEFT SIDE.                 04400000
R3       EQU   3                                                        04600000
ABS      EQU   3                   ABSOLUTE VALUE OF FETCHED ELEMENT.   04800000
BLS      EQU   4                   BASE OF LEFT SIDE.                   05000000
R4       EQU   4                                                        05200000
RXI      EQU   5                   HOLDS RX(I).                         05400000
Q0       EQU   6                   LEFT HALF OF MULTIPLICAND.           05600000
Q1       EQU   7                   RIGHT HALF OF MULTIPLICAND.          05800000
W0       EQU   8                   LEFT HALF OF MULTIPLICAND.           06000000
W1       EQU   9                   RIGHT HALF OF MULTIPLICAMD.          06200000
UPDOWN   EQU   10                  HOLDS CORRECT BRANCH ADDRESS.        06400000
I4       EQU   LKR                 HOLDS FOUR TIMES I.                  06600000
         USING OPSECT-16,LR                                             06800000
         USING *,9                                                      07000000
EXTAKE   LA    9,LWUP-LWDOWN+EXLEAVE-EXTAKE(9) GET SET FOR UP ARROW.    07200000
         USING *,9                 THIS PROVED TO BE NECESSARY.         07400000
EXLEAVE  LA    UPDOWN,LWDOWN       ADDRESS OF CORRECT BRANCH PLACE.     07600000
         ST    PR,KEEPPR           SAVE THE PROGRAM REGISTER.           07800000
         ST    LKR,KEEPLKR         SAVE THE RETURN ADDRESS.             08000000
         L     I,LHXRHO            NUMBER OF ELEMENTS IN LEFT SIDE.     08200000
         LA    ABS,0(I,I)          USE ABS FOR A WORK ARE.              08400000
         AR    ABS,ABS             MULTIPLY I BY FOUR IN ABS.           08600000
         L     R0,LHRANK           FOUR TIMES THE NUMB. OF DIMS.        08800000
         BALR  PR,0                                                     09000000
         USING *,PR                                                     09200000
         LA    Q1,CALLERR                                               09400000
         LA    R1,ERANK                                                 09600000
         L     Q0,RHRANK                                                09800000
         CH    R0,HALF4                                                 10000000
         BCR   2,Q1                                                     10200000
         LA    R1,ELENGTH                                               10400000
         BC    8,SETLM0                                                 10600000
         CH    Q0,HALF4                                                 10800000
         BCR   2,Q1                                                     11000000
SETLM0   LTR   Q0,Q0                                                    11200000
         BC    8,SETLM                                                  11400000
         CR    ABS,Q0                                                   11600000
         BCR   7,Q1                                                     11800000
SETLM    CH    I,HALFA                                              A01 12000000
         LA    R1,ERANGE                                                12200000
         BCR   11,Q1                                                A01 12400000
         CR    ABS,Q0                                               A01 12600000
         BC    10,SETLM1                                                12800000
         LR    ABS,Q0                                                   13000000
         LR    I,ABS                                                    13200000
         SRL   I,2                                                      13400000
SETLM1   EQU   *                                                        13600000
         ST    ABS,ANSRANK                                              13800000
         SH    ABS,HALF8           SUBTRACT 8 FOR THE LIMIT.            14000000
         ST    ABS,LIM             STASH AWAY THE LIMIT.                14200000
         L     BLS,LHBASE          SET UP BLS TO CONTAIN THE M-RELATIVE 14400000
         A     BLS,LHRANK          ADDRESS OF ELEMENT ZERO OF THE LEFT  14600000
         LA    BLS,MRHO-M(BLS)     ARGUMENT.                            14800000
         LR    R1,I                SET UP THE INITIAL INDEX FOR LHS.    15000000
         BCTR  I,0                 XX                                   15200000
         BXLE  R1,R1,LEFTMT        EMPTY VECTOR OF NUMBERS. NOW WHAT?   15400000
         LA    R0,1                                                     15600000
         ST    R0,LSP              SET THE SPACE TO ONE.                15800000
         LA    Q0,SEE              SET UP RETURN ADDRESS FROM FETCH.    16000000
* FETCH AN ELEMENT FROM THE LEFT SIDE, SET UP ABS TO CONTAIN THE     *  16200000
* ABSOLUTE VALUE OF THE NUMBER FETCHED, CHECK THE ABSOLUTE VALUE FOR *  16400000
* A POSSIBLE DOMAIN ERROR, AND MAKE I4 CONTAIN FOUR TIMES I.         *  16600000
BEGET    ST    I,RAT                                                    16800000
         C     I,LHXRHO                                                 17000000
         BC    4,BEGET1                                                 17200000
         SR    I,I                                                      17400000
BEGET1   L     3,LHTYPE            GET READY FOR FETCHINT.              17600000
         ICALL FETCHINT            FETCH THAT INTEGER.                  17800000
         L     I,RAT                                                    18000000
         LA    I4,0(I,I)           GET I+I IN I4.                       18200000
         AR    I4,I4               THEN GET I+I+I+I IN I4.              18400000
         L     RXI,RHBASE          NOW I GET (RHO X)(I) IN RXI.         18600000
         LA    RXI,MRHO(RXI)       XX                                   18800000
         L     RXI,0(RXI,I4)       XX                                   19000000
         CLI   RHRANK+3,X'00'                                           19200000
         BC    7,BEGAT                                                  19400000
         LA    RXI,1                                                    19600000
BEGAT    LPR   ABS,R0                                                   19800000
         BCR   15,UPDOWN                                                20000000
LWDOWN   CR    RXI,ABS                                                  20200000
         BC    10,LWDN1                                                 20400000
         LR    R0,RXI                                                   20600000
LWDN1    LR    R1,RXI                                                   20800000
         LTR   R0,R0                                                    21000000
         BC    4,LWDN2                                                  21200000
         LCR   R1,R1                                                    21400000
LWDN2    AR    R0,R1                                                    21600000
         LPR   ABS,R0                                                   21800000
LWUP     MVC   FEEL,ZORROS                                              22000000
         ST    ABS,K(I4)                                                22200000
         CR    ABS,RXI                                                  22400000
         BC    12,LWUP1                                                 22600000
         ST    RXI,K(I4)                                                22800000
         SR    ABS,RXI                                                  23000000
         LTR   R0,R0                                                    23200000
         BC    10,LWUP0                                                 23400000
         LCR   ABS,ABS                                                  23600000
LWUP0    ST    ABS,FEEL                                                 23800000
         LPR   ABS,ABS                                                  24000000
         AR    ABS,RXI                                                  24200000
LWUP1    ST    ABS,RHOS(I4)                                             24400000
         LR    R1,R0                                                    24600000
         BCR   15,Q0                                                    24800000
*                                                                       25000000
WSFULL   LA    1,EMFULL            MUCH TOO BIG MATRIX REQUIRED         25200000
CALLERR  ICALL ERROR               I CALL THE ERROR ROUTINE. GOODBYE.   25400000
LEFTMT   MVI   TEMPRGT,X'00'                                            25600000
         L     R1,SVI                                                   25800000
         A     R1,NEG4                                                  26000000
         ST    R1,SVI                                                   26200000
         L     R0,M+20(R1)                                              26400000
         ST    R0,M+4(R1)                                               26600000
         BC    15,THEEND                                                26800000
SEE      ST    ABS,CNTSAVE         STORE THE COUNT FOR THE MOVES.       27000000
         CR    ABS,RXI                                                  27200000
         BC    12,SEE1                                                  27400000
         ST    RXI,CNTSAVE                                              27600000
SEE1     EQU   *                                                        27800000
         SR    RXI,ABS             CALCULATE THE RESIDUE.               28000000
         ST    RXI,RES             XX                                   28200000
         AR    RXI,ABS             ADD BACK WHAT WAS SUBTRACTED.        28400000
         SR    W0,W0               ZERO OUT THE SUM.                    28600000
         ST    W0,SUMS             XX                                   28800000
         C     W0,FEEL                                                  29000000
         BC    8,SEE3                                                   29200000
         BC    2,SEE2                                                   29400000
         S     W0,FEEL                                                  29600000
SEE2     ST    W0,RES                                                   29800000
         SR    W0,W0                                                    30000000
SEE3     S     W0,FEEL                                                  30200000
         BC    10,SEE4                                                  30400000
         SR    W0,W0                                                    30600000
SEE4     ST    W0,FRONT                                                 30800000
         SR    W0,W0                                                    31000000
         LA    W1,1                START WITH A WEIGHT OF ONE.          31200000
         LR    Q1,W1               ASLO START WITH AN INCREMENT OF ONE. 31400000
**********************************************************************  31600000
*  BEGIN THE FIRST LOOP,  CALCULATING THINGS FOR THE NEXT LOOP.      *  31800000
**********************************************************************  32000000
IT       ST    Q1,INC(I4)          STORE THE CURRENT INCREMENT.         32200000
         L     Q1,LSP                                                   32400000
         M     Q0,FEEL                                                  32600000
         ST    Q1,FILL(I4)                                              32800000
         SR    Q0,Q0                                                    33000000
         L     Q1,LSP                                                   33200000
         MR    Q0,ABS                                                   33400000
         ST    Q1,LSP                                                   33600000
         LTR   Q0,Q0               REJECT MUCH TOO BIG RESULT           33800000
         BNZ   WSFULL                                                   34000000
         LR    Q1,RXI              CALCULATE THE NEXT INCREMENT.        34200000
         SR    Q1,ABS              XX                                   34400000
         BC    10,IT1                                                   34600000
         SR    Q1,Q1                                                    34800000
IT1      EQU   *                                                        35000000
         MR    Q0,W1               XX                                   35200000
         LTR   R1,R1               SEE IF THE SELECTED POSITIONS ARE    35400000
         BC    10,RUN              AT THE BEGINNING OR END OF THE ROW.  35600000
         LR    Q0,Q1               THEY ARE AT THE END.                 35800000
         A     Q0,SUMS             ECHE SUMS ACCORDINGLY.               36000000
         ST    Q0,SUMS             XX                                   36200000
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *   36400000
RUN      MR    W0,RXI              CALCULATE THE NEXT WEIGHT.           36600000
         SH    I,HALF1             DECREASE THE INDEX BY ONE, AND TEST  36800000
         LA    Q0,IT               FOR THE END OF LOOP ONE.             37000000
         BC    10,BEGET            XX                                   37200000
**********************************************************************  37400000
* NOW DO SOME PRELIMINARY SETTING UP FOR THE NEXT LOOP, LIKE GETTING *  37600000
* SPACE FOR THE RESULT, SETTING UP REGISTERS, ETC..                  *  37800000
**********************************************************************  38000000
COUNT    EQU   3                   THESE ARFE THE REGISTER USES IN THIS 38200000
FROM     EQU   4                   THIS LOOP.                           38400000
TO       EQU   5                   THIS IS THE SINK ADDRESS.            38600000
V        EQU   6                   THIS IS THE INDEX FOR THE SINK.      38800000
SUM      EQU   7                   INDEX OF SOUCE ELEMENT.              39000000
Y        EQU   8                   HOLDS THE CURRENT COUNTER FOR MOVES. 39200000
NEG4R    EQU   9                   HOLDS A NEGATIVE FOUR.               39400000
MOVER    EQU   10                  ADDRESS OF MOVE ROUTINE.             39600000
         L     R1,LSP                                                   39800000
         L     R2,ANSRANK                                               40000000
         L     FROM,RHBASE                                              40200000
         SR    R3,R3                                                    40400000
         IC    R3,MTYPE(FROM)                                           40600000
         ST    R3,RHTYPE                                                40800000
         L     10,=A(OPSPACE)      USE ALREADY EXISTING TECHNIQUES.     41000000
         BALR  LKR,10              XX                                   41200000
         LR    TO,R1               GET THE ADDRESS OF THE NEW SPACE.    41400000
         AR    R1,MR               MAKE AN ABSOLUTE ADDRESS OF IT.      41600000
         L     FROM,RHBASE         GET THE SOURCE ADDRESS.              41800000
         L     R2,MTYPE(FROM)      PUT THE TYPE AND NUMBER OF           42000000
HALF8    EQU   *+2                 HERE IS A CONVENIENT ADDRESS.        42200000
         ST    R2,MTYPE-M(R1)      DIMENSIONS IN THE NEW SPACE.         42400000
         L     R2,ANSRANK                                               42600000
HALFA    EQU   *+2                                                      42800000
         STH   R2,MRANK-M(R1)                                           43000000
         BCTR  R2,0                THIS IS FOR THE MVC COUNT.           43200000
         EX    R2,ARRWMVC          THERE GOES THE RANK VECTOR.          43400000
         L     R2,ANSRANK                                               43600000
         LA    TO,MRHO-M(R2,TO)    ADDRESS OF ELEMENT ZERO OF THE SINK. 43800000
         L     R2,RHRANK           NOW I MAKE TO CONTAIN THE M-RELATIVE 44000000
         LA    FROM,MRHO-M(R2,FROM)  LIKEWISE, I SET THE RECIEVING END. 44200000
         SR    V,V                 LET IT BEGIN WITH NOTHING.           44400000
         C     V,LSP               SEE IF THERE ARE ANY ELEMENTS IN     44600000
         BC    10,THEEND           THE RESULT, IF NOT SKIP IT.          44800000
         L     SUM,SUMS            GET THAT SUM.                        45000000
         LA    MOVER,LJWMOVE       SET UP THE BASE REGISTER FOR MOVES.  45200000
         L     NEG4R,NEG4          SET UP THAT CONSTANT.                45400000
         LR    I,NEG4R             BEGIN WITH A MINUS NUMBER.           45600000
HALF1    EQU   *+2                 ANOTHER CONVENIENT ADDRESS.          45800000
         LA    Y,1                 THIS ADDRESS IS USED AS A CONSTANT.  46000000
         C     V,RHXRHO                                                 46200000
         BC    7,THEN                                                   46400000
         L     COUNT,LSP                                                46600000
         LA    LKR,THEEND                                               46800000
         BC    15,FILLUP                                                47000000
**********************************************************************  47200000
* THIS IS THE REAL LOOP, IN WHICH THE APPROPRIATE MOVE ROUTINE GETS  *  47400000
* CALLED THE CORRECT NUMBER OF TIMES WITH THE RIGHT SETUP EACH TIME. *  47600000
**********************************************************************  47800000
TRY      SR    I,NEG4R             ADD PLUS FOUR.                       48000000
         SR    COUNT,COUNT                                              48200000
         S     COUNT,FILL(I)                                            48400000
         BC    12,LOAD                                                  48600000
         BAL   LKR,FILLUP                                               48800000
LOAD     L     Y,K(I)              LOAD THE COUNT FOR THIS DIMENSION.   49000000
STORE    ST    Y,J(I)              INITIALIZE THE COUNTER.              49200000
THEN     C     I,LIM               INITIALIZE ALL COUNTERS FROM HERE    49400000
         BC    4,TRY               DOWN TO THE LAST DIMENSION.          49600000
DOTHE    L     COUNT,FRONT                                              49800000
         LTR   COUNT,COUNT                                              50000000
         BC    8,MOVE                                                   50200000
         BAL   LKR,FILLUP                                               50400000
MOVE     L     COUNT,CNTSAVE       SET UP THE COUNT OF ELEMENTS TO      50600000
         L     R1,RHTYPE           TYPE FOR THE MOVE ROUTINES.          50800000
         BALR  LKR,MOVER           BE MOVED, AND THEN MOVE THEM.        51000000
         SR    COUNT,COUNT                                              51200000
         S     COUNT,RES                                                51400000
         BC    12,SURELY                                                51600000
         LA    LKR,MOVING                                               51800000
         BC    15,FILLUP                                                52000000
SURELY   A     SUM,RES             ADD IN THE PART LEFT OVER, IF ANY.   52200000
MOVING   QUEND                                                          52400000
         BCT   Y,DOTHE                                                  52600000
         CR    I,NEG4R                                                  52800000
         BC    8,THEEND                                                 53000000
ON       SR    COUNT,COUNT                                              53200000
         A     COUNT,FILL(I)                                            53400000
         BC    12,WARD                                                  53600000
         BAL   LKR,FILLUP                                               53800000
WARD     BXLE  I,NEG4R,THEEND                                           54000000
TOO      A     SUM,INC(I)                                               54200000
         L     Y,J(I)                                                   54400000
         BCT   Y,STORE                                                  54600000
         CR    NEG4R,I                                                  54800000
         BC    4,ON                                                     55000000
THEEND   L     LKR,KEEPLKR         RESTORE THE LKR AND THE PR.          55200000
         L     PR,KEEPPR           THEN EXIT.                           55400000
         BCR   15,LKR              XX                                   55600000
ARRWMVC  MVC   MRHO-M(0,R1),RHOS   MVC FOR FILLING IN THE RANK OF NEW.  55800000
FILLUP   L     R1,RHTYPE                                                56000000
         AR    R5,MR                                                    56200000
         BCT   R1,FILLINT                                               56400000
FLIB1    SH    R6,K32                                                   56600000
         BC    4,FLIB2                                                  56800000
HALF4    EQU   *+2                                                      57000000
         LA    R5,4(R5)                                                 57200000
         BC    15,FLIB1                                                 57400000
FLIB2    L     R0,0(R5)                                                 57600000
         LCR   R6,R6                                                    57800000
         SRL   R0,0(R6)                                                 58000000
         SLL   R0,0(R6)                                                 58200000
         ST    R0,0(R5)                                                 58400000
         CR    R6,COUNT                                                 58600000
         BC    4,FLIB4                                                  58800000
         LCR   R6,R6                                                    59000000
         LA    R6,32(R6,COUNT)                                          59200000
         SR    R5,MR                                                    59400000
         BCR   15,LKR                                                   59600000
FLIB4    SR    COUNT,R6                                                 59800000
         LA    R5,4(R5)                                                 60000000
         LR    R6,COUNT                                                 60200000
         LA    COUNT,7(COUNT)                                           60400000
         SRL   COUNT,3                                                  60600000
         BCTR  COUNT,0                                                  60800000
         EX    COUNT,FLIBXC                                             61000000
         LA    R1,255                                                   61200000
         SR    R5,MR                                                    61400000
         CR    COUNT,R1                                                 61600000
         BCR   12,LKR                                                   61800000
         NR    R1,COUNT                                                 62000000
         AR    R1,MR                                                    62200000
         LA    R1,1(R1,R5)                                              62400000
         SRL   COUNT,8                                                  62600000
FLIB5    XC    0(256,R1),0(R1)                                          62800000
         LA    R1,256(R1)                                               63000000
         BCT   COUNT,FLIB5                                              63200000
         BCR   15,LKR                                                   63400000
FILLINT  SR    R0,R0                                                    63600000
         IC    R1,PIKTYPE(R1)                                           63800000
         LTR   R1,R1                                                    64000000
         BC    8,FLARC                                                  64200000
FLINT1   SLL   COUNT,0(R1)                                              64400000
         SLL   R6,0(R1)                                                 64600000
         AR    R5,R6                                                    64800000
         LR    R6,COUNT                                                 65000000
         AR    COUNT,NEG4R                                              65200000
FLINTINT ST    R0,0(R5,COUNT)                                           65400000
         BXH   COUNT,NEG4R,FLINTINT                                     65600000
         AR    R5,R6                                                    65800000
         SR    R6,R6                                                    66000000
         SR    R5,MR                                                    66200000
         BCR   15,LKR                                                   66400000
FLARC    LA    R0,ZBLANK                                                66600000
         AR    R5,R6                                                    66800000
         LR    R6,COUNT                                                 67000000
         BCTR  R5,0                                                     67200000
FLARC1   STC   R0,0(R5,COUNT)                                           67400000
         BCT   COUNT,FLARC1                                             67600000
         SR    R5,MR                                                    67800000
         LA    R5,1(R5,R6)                                              68000000
         LR    R6,COUNT                                                 68200000
         BCR   15,LKR                                                   68400000
FLIBXC   XC    0(0,R5),0(R5)                                            68600000
****************************************                                68800000
* MISCELLANEOUS CONSTANTS.             *                                69000000
****************************************                                69200000
         CNOP  0,4                 ALIGN ON A FULL WORD BOUNDARY.       69400000
NEG4     DC    XL4'FFFFFFFC'       A NEGATIVE FOUR.                     69600000
ZORROS   DC    XL4'00000000'                                            69800000
         LTORG *                   AND HERE ARE THE LITERALS.           70000000
*********************************************************************** 70200000
***  THESE ARE THE MOVE ROUTINES.   *********************************** 70400000
** CONVENTIONS.......              *                                    70600000
** R1 = ARRAY TYPE, 1=BITS, 2=INTEGERS, 3=FLOATING, 4=CHARACTERS. ***** 70800000
** R2 IS PRESERVED.                *                                    71000000
** R3 = COUNT OF ELEMENTS TO MOVE. *                                    71200000
** R4 = SOURCE ADDRESS, M-RELATIVE.                                     71400000
** R5 = SINK ADDRESS, M-RELATIVE.                                       71600000
** R6 = DESTINATION INDEX.         *                                    71800000
** R7 = SOURCE INDEX               *                                    72000000
*********************************************************************** 72200000
LJWMOVE  EQU   *                   THIS IS THE GENERAL PURPOSE MOVE RTN 72400000
         USING *,MOVER             IT EVEN HAS ITS OWN BASE REGISTER.   72600000
         BCT   R1,MOVEINT          BRANCH IF IT IS NOT A BIT MOVE.      72800000
MVBIT1   SH    R6,K32              ADJUST THE BIT INDICES SO THAT       73000000
         BC    4,MVBIT2            THEY ARE LESS THAN 32.               73200000
         LA    R5,4(R5)            XX                                   73400000
         BC    15,MVBIT1           XX                                   73600000
MVBIT2   SH    R7,K32              THE BASIC APPROACH IN THIS ROUTINE   73800000
         BC    4,MVBIT3            IS TO MOVE ENOUGH BITS INITIALLY TO  74000000
         LA    R4,4(R4)            MAKE THE DESTINATION FIELD START ON  74200000
         BC    15,MVBIT2           A FULL WORD BOUNDARY.                74400000
MVBIT3   AR    R4,MR               THEN THE NUMBER OF BITS MOVED IS     74600000
         AR    R5,MR               COMPARED AGAINST THE COUNT.          74800000
         LM    R0,R1,0(R4)         IF THE NUMBER OF BITS MOVED TO       75000000
         LCR   R7,R7               FILL OUT THE WORD IN THE DESTINATION 75200000
         SRDL  R0,0(R7)            FIELD IS AT LEAST AS LARGE AS THE    75400000
         L     R0,0(R5)            COUNT, THEN I AM ALL FINISHED MOVING 75600000
         LCR   R6,R6               THE BITS, AND MERELY HAVE TO ADJUST  75800000
         SRL   R0,0(R6)            THE BIT INDICES IN R6 AND R7 FOR THE 76000000
         SLDL  R0,0(R6)            NEXT ENTRY INTO THIS ROUTINE.        76200000
         ST    R0,0(R5)                                                 76400000
         CR    R6,COUNT            IF THERE ARE STILL MORE BITS TO BE   76600000
         BC    4,MVBIT4            MOVED, THEN I GO INTO A LOOP TO      76800000
*                                  MOVE THE REMAINDER.                  77000000
*---------------------------------------------------------------------- 77200000
         LCR   R6,R6               HERE THE COUNT IS NOT GREATER THAN   77400000
         LA    R6,32(R6,COUNT)     THE NUMBER OF BITS ALREADY MOVED.    77600000
         LCR   R7,R7               FIX UP R7.                           77800000
         LA    R7,32(R7,COUNT)     XX                                   78000000
         SR    R5,MR               MAKE THESE M-RELATIVE AGAIN.         78200000
         SR    R4,MR               XX                                   78400000
         BCR   15,LKR              RETURN TO FROM WHENCE IT CAME.       78600000
MVBIT4   LCR   R7,R7               HERE IS THE LOOP TO MOVE THE REST    78800000
         LA    R7,32(R6,R7)        OF THE BITS.                         79000000
         SR    COUNT,R6            NOTE THE INTERESTING SEQUENCE WITH   79200000
         LA    R6,32               THE LM, SLDL, AND ST.                79400000
K32      EQU   *-2                 MIGHT AS WELL USE THIS.              79600000
         CR    R7,R6                                                    79800000
         BC    4,MVBIT6                                                 80000000
         SH    R7,K32                                                   80200000
MVBIT5   LA    R4,4(R4)                                                 80400000
MVBIT6   LA    R5,4(R5)                                                 80600000
         LM    R0,R1,0(R4)                                              80800000
         SLDL  R0,0(R7)                                                 81000000
         ST    R0,0(R5)                                                 81200000
         SR    COUNT,R6                                                 81400000
         BC    2,MVBIT5                                                 81600000
         AR    R6,COUNT                                                 81800000
         AR    R7,R6                                                    82000000
         SR    R4,MR                                                    82200000
         SR    R5,MR                                                    82400000
         BCR   15,LKR                                                   82600000
* TYPE 2, 3, OR 4 TAKEN CARE OF HERE.                                   82800000
MOVEINT  EQU   *                   MOVE INTEGER.                        83000000
MOVECHR  EQU   *                   CHARACTER MOVES PROCESSED HERE.      83200000
MOVEFLP  EQU   *                   FLOATING POINT MOVES HERE.           83400000
         IC    R1,PIKTYPE(R1)      GET THE SHIFT AMOUNT.                83600000
         SLL   COUNT,0(R1)         MULTIPLY THE COUNT BY THE ELEMENT    83800000
         SLL   R6,0(R1)            SIZE, AS WELL AS THE INDICES FOR THE 84000000
         SLL   R7,0(R1)            SOURCE AND SINK.                     84200000
R7       EQU   7                                                        84400000
R6       EQU   6                                                        84600000
R5       EQU   5                                                        84800000
         AR    R4,MR                                                    85000000
         AR    R4,R7               ADD THE INDEX TO THE SOURCE ADDRESS. 85200000
         AR    R5,MR                                                    85400000
         AR    R5,R6               ADD THE INDEX TO THE SINK ADDRESS.   85600000
         AH    COUNT,NEG257                                             85800000
         LA    R0,256              PREPARE FOR THE BXLE.                86000000
         BC    4,LAST1             BRANCH IF ONLY ONE MVC.   A524       86200000
R0       EQU   0                                                        86400000
         LA    R1,0(TO,COUNT)                                           86600000
MOVEIT   MVC   0(256,TO),0(FROM)                                        86800000
         AR    FROM,R0                                                  87000000
         BXLE  TO,R0,MOVEIT                                             87200000
LAST1    EX    COUNT,MVCMINE                                            87400000
         LA    R6,255              PREPARE TO ADD INTO THE TO, FROM TH  87600000
         NR    R6,COUNT            AMOUNT OF THE LAST (SHORT) MOVE.     87800000
         SR    R6,MR               SIMULTANEOULSY RELATIVIZE THE PTRS.  88000000
         LA    TO,1(TO,R6)                                              88200000
         LA    FROM,1(FROM,R6)                                          88400000
         SR    R6,R6               MAKE THE RELATIVE ELEMENT INDICES    88600000
         LR    R7,R6               ZERO AGAIN.                          88800000
         BCR   15,LKR                                                   89000000
MVCMINE  MVC   0(0,TO),0(FROM)                                          89200000
NEG257   DC    XL2'FEFF'                                                89400000
PIKTYPE  DC    XL1'FF'             TYPE                                 89600000
         DC    XL1'02'             TYPE TWO, INTEGER.                   89800000
         DC    XL1'03'             TYPE 3, FLOATING POINT.              90000000
         DC    XL1'00'             TYPE 4, CHARACTERS.                  90200000
**********************************************************************  90400000
*****  THIS IS MY DSECT, WHICH I HOPE FITS IN WITH OPSECT. ***********  90600000
**********************************************************************  90800000
OPSECT   DSECT                                                          91000000
         ORG   FACTSAVE            THIS SHOULD WORK.                    91200000
KEEPPR   DC    XL4'00000000'       HOLDS THE BASE REGISTER FOR OTHER .  91400000
KEEPLKR  DC    XL4'00000000'       SPACE TO SAVE THE LINK REGISTER.     91600000
CNTSAVE  DC    XL4'00000000'       SAVE THE COUNT FOR MOVE ROUTINES.    91800000
SUMS     DC    XL4'00000000'       SAVE THE SUM.                        92000000
LIM      DC    XL4'00000000'       LIMIT FOR A IN SECOND LOOP.          92200000
RES      DC    XL4'00000000'       THE RESIDUE.                         92400000
K        DC    XL4'00000000'       THE COUNTERS FOR VARIOUS DIMENSIONS. 92600000
         DC    10XL4'00000000'     XX                                   92800000
         ORG    TESTAREA           I MUST NOT USE THAT OTHER WORD, BAD. 93000000
LSP      DC    XL4'FFFFFFFF'                                            93200000
INC      DC    XL4'00000000'       THE INCREMENTS FOR DIMENSIONS.       93400000
         DC    10XL4'00000000'     XX                                   93600000
FRONT    DC    XL4'00000000'                                            93800000
ANSRANK  DC    XL4'00000000'                                            94000000
FILL     DC    XL4'00000000'                                            94200000
         DC    10XL4'00000000'                                          94400000
J        DC    XL4'00000000'       THE CURRENT COUNTERS.                94600000
RHOS     EQU   J                                                        94800000
         DC    10XL4'00000000'     XX                                   95000000
RAT      DC    XL4'00000000'                                            95200000
FEEL     DC    XL4'00000000'                                            95400000
         END                                                            95600000
./  ADD    NAME=APLSTBCD
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00330000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00660000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00990000
         PRINT OFF       APLDEFN, ZSYMBOLS                              01320000
TBCD     TITLE 'O U T P U T   C O N V E R S I O N             05/11/70' 01980000
TOBCD    CSECT                                                          02310000
         COPY  APLDEFN                                                  02640000
         COPY  ZSYMBOLS                                                 02970000
         TITLE 'O U T P U T   C O N V E R S I O N             05/11/70' 03300000
TOBCD    CSECT                                                          03630000
         PRINT ON                                                       03960000
         EXTRN DPDIV                                                    04290000
         EXTRN DPMUL                                                    04620000
         EXTRN SQUIRT                                                   04950000
         EXTRN TOPRINT                                                  05280000
         PROLOG TOBCDWK,TOBEND                                          05610000
*                                                                       05940000
*        TOBCD     OUTPUT CONVERSION AND FORMATTING ROUTINE             06270000
*              CALL .. ICALL TOBCD                                      06600000
*              R0,R1 = VALUE, LEFT-JUSTIFIED                            06930000
*              R2    = TYPE = 1, 2, 3, 4                                07260000
*              R3    = CONTROL INFORMATION --                           07590000
*                  BYTES 0, 1      PLACES LEFT OF DECIMAL POINT         07920000
*                                  (FLOATING CONVERSION ONLY)           08250000
*                  BYTES 2, 3      FIELD WIDTH (ZERO IF FREE-FIELD)     08580000
*                                                                       08910000
         STM   3,6,WIDTH           SAVE CONTROL INFORMATION AND R4-R6   09240000
         BCT   2,TBCDINT           FALL THROUGH IF LOGICAL CONVERSION   09570000
*  IT IS A LOGICAL VARIABLE, PLACE A ZERO OR A ONE IN THE OUTPUT BYTE.* 09900000
         SRL   0,31                                                     10230000
         B     TBCDINT2            TREAT IT AS AN INTEGER 1 OR 0 .      10560000
TBCDBITE SRL   0,24                                                     10890000
         LR    1,0                                                      11220000
         ICALL TOPRINT                                                  11550000
         IRETURN                                                        11880000
TBCDINT  BCT   2,TBFLT             FALL THROUGH IF INTEGER CONVERSION   12210000
TBCDINT2 CVD   0,TBFLTW1           CONVERT TO DECIMAL                   12540000
         MVI   TBSTRING,X'FC'      AND EDIT INTO A 12-CHARACTER FIELD   12870000
         MVI   TBSTRING+1,X'20'    WITH LEADING BLANKS.                 13200000
         MVC   TBSTRING+2(10),TBSTRING+1                                13530000
         MVI   TBSTRING+10,X'21'   ZERO EDITED TO SINGLE DIGIT          13860000
         LA    1,TBSTRING+11       ANTICIPATE ZERO VALUE                14190000
         LR    4,1                 R4 IS END-OF-SIGNIFICANCE ADDRESS    14520000
         EDMK  TBSTRING(12),TBFLTW1+2                                   14850000
         BNL   TBCDINT3            RESULT IS POSITIVE OR ZERO           15180000
         BCTR  1,0                 PREFACE NEGATIVE VALUE BY HIGH       15510000
         MVI   0(1),X'FA'          MINUS SIGN.                          15840000
*              FOR PROCESSING AT TBX, SET UP ...                        16170000
TBCDINT3 LR    6,4                 R4 = ADDR OF RIGHTMOST SIGNIFICANT   16500000
         SH    6,WIDTH+2           R6 = ADDR OF LEFT END - 1, FOR MATRX 16830000
         BCT   1,TBX               R1 = ADDR OF LEFT END - 1, FOR VECTR 17160000
*                                  (BRANCH ALWAYS GOES)                 17490000
         SPACE 2                                                        17820000
TBFLT    BCT   2,TBCDBITE          FALL THROUGH IF FLOATING CONVERSION  18150000
         STM   0,1,TBFLTW0                                              18480000
         LD    0,TBFLTW0                                                18810000
         LA    3,85                R3 WILL CONTAIN THE DECIMAL EXPONENT 19140000
*                                  OFFSET BY 100 TO KEEP IT POSITIVE.   19470000
*                                  85 IS A GLITCH FOR CONSTANT 0.0      19800000
         SDR   2,2                                                      20130000
         ADR   0,2                 MAKE SURE CONVERTEE IS NORMALIZED    20460000
         STE   0,TBFLTW0           REMOVE NEG SIGN IF NEG 0             20790000
         LPER  0,0                 REMOVE SIGN OF CONVERTEE             21120000
         BZ    TBFLTZRO            QUIT SCALING IF ZERO                 21450000
         LA    3,100                                                    21780000
         LA    4,D106              PREPARE FOR LARGE SCALEDOWN          22110000
         LA    5,TBDIV             EITHER SINGLE PRECISION              22440000
         CLI   OSIGDIG+3,14        FOR 13 DIGITS OR LESS,               22770000
* NON CRITICAL -- CHANGE 14 TO 16 WHEN GUARD DIGIT EC INSTALLED         23100000
         BL    *+8                                                      23430000
         L     5,=A(DPDIV)         OR DOUBLE PRECISION.                 23760000
         BALR  2,0                                                      24090000
         CE    0,QBSD              DO WE NEED A BIG SCALEDOWN --        24420000
         BL    TBFLT2              NO.                                  24750000
         LA    3,6(3)              BUMP EXPONENT BY 6.                  25080000
         BR    5                   SCALE DOWN BY 1E6.                   25410000
TBFLT2   LA    4,D10               PREPARE FOR SMALL SCALEDOWN          25740000
         BALR  2,0                                                      26070000
         CE    0,QSSD              DO WE NEED A SMALL SCALEDOWN --      26400000
         BL    TBFLT2A             NO.                                  26730000
         LA    3,1(3)              YES.  BUMP EXPONENT BY 1.            27060000
         BR    5                   SCALE DOWN BY 10.0                   27390000
TBFLT2A  CH    3,QH100             CHECK FOR ZERO (100) EXPONENT        27720000
         BNZ   TBRND               IF NONZERO, FRACTION WAS SCALED UP   28050000
*                                  AND NEEDN'T BE SCALED DOWN AGAIN.    28380000
         LA    5,TBMUL             PREPARE FOR SINGLE PRECISION         28710000
         CLI   OSIGDIG+3,14        OR DOUBLE PRECISION MULTIPLY.        29040000
         BL    *+8                                                      29370000
         L     5,=A(DPMUL)                                              29700000
         LD    6,D106                                                   30030000
         BALR  2,0                                                      30360000
         SH    3,QH6               DROP DECIMAL EXPONENT                30690000
         CE    0,QBSU              DO WE NEED A BIG SCALEUP --          31020000
         BCR   4,5                 YES.                                 31350000
         LD    6,D10                                                    31680000
         BALR  2,0                                                      32010000
         BCTR  3,0                 DROP DECIMAL EXPONENT                32340000
         CE    0,QSSU              DO WE NEED A SMALL SCALEUP --        32670000
         BCR   4,5                 YES.                                 33000000
         LA    3,7(3)              CORRECT EXPONENT AGAIN.              33330000
TBRND    L     1,OSIGDIG           PREPARE TO ROUND FRACTION BY 5 IN    33660000
         CD    0,D1016             FIRST NONPRINTING POSITION           33990000
         BL    TBRND1                                                   34320000
         BCTR  1,0                                                      34650000
TBRND1   SLA   1,2                                                      34980000
         SDR   4,4                 CLEAR LONG REGISTER                  35310000
         LE    4,DRND-4(1)         AND LOAD SHORT CONSTANT.             35640000
         ADR   2,4                 ADD ROUNDING CONSTANT INTO SMALL     35970000
         ADR   0,2                 PART OF FRACTION, THEN COMBINE FRACS 36300000
*              REENTRY FOR ZERO VALUE.  EXPONENT IS 1.                  36630000
TBFLTZRO STD   0,TBFLTW1           NOW 1.6E16 GTR D0 GEQ 1E15           36960000
         MVI   TBFLTW1,X'00'       GET RID OF THE EXPONENT BITS.        37290000
         LM    0,1,TBFLTW1         GET R AND Q IN R0 AND R1 SO THAT     37620000
         D     0,QF1E8             ((Q X 1E8)+R) = N .                  37950000
         CVD   0,TBFLTW2           CONVERT R TO DECIMAL                 38280000
         CVD   1,TBFLTW1           CONVERT Q TO DECIMAL                 38610000
*                                                                       38940000
*                                            01234567                   39270000
*                                            --------                   39600000
*                                  W1 IS NOW 000XXXXX                   39930000
*                                            000XXXXS                   40260000
*                                                                       40590000
*                                            01234567                   40920000
*                                            --------                   41250000
*                                  W2 IS NOW 0000XXXX                   41580000
*                                            000XXXXS                   41910000
*                                                                       42240000
         MVZ   TBFLTW2+3(1),TBFLTW1+7  CATENATE THE QUOTIENT AND        42570000
         MVC   TBFLTW1+7(4),TBFLTW1+3  DIVISOR, IGNORING THE SIGN OF    42900000
*                                      THE QUOTIENT.                    43230000
*  NOW THERE ARE 17 DECIMAL DIGITS PLUS THE SIGN IN THE NUMBER,      *  43560000
* BEGINNING AT TBFLTW1+7 AND ENDING WITH TBFLTW2+7.                     43890000
         MVI   TBFILL,X'FC'                                             44220000
         MVC   TBFILL+1(18),TBFILL CREATE EDIT PATTERN OF BLANKS AND    44550000
         MVI   TBSTRING+7,X'21'                                         44880000
         MVC   TBSTRING+8(16),TBSTRING+7 SIGNIFICANCE STARTERS.         45210000
         EDMK  TBSTRING+6(18),TBFLTW1+7                                 45540000
*                                                                       45870000
*              IN THE FOLLOWING,                                        46200000
*              R2 = ADDRESS OF LEFTMOST SIGNIFICANT CHARACTER           46530000
*              R3 = DECIMAL EXPONENT                                    46860000
*              R4 = ADDRESS OF RIGHTMOST SIGNIFICANT CHARACTER          47190000
*              R5 = ADDRESS AT WHICH TO INSERT DECIMAL POINT            47520000
*                   (POSSIBLY DISPLACED 1 TO THE LEFT)                  47850000
*              R6 = ADDRESS OF LEFT END OF FIELD TO BE PRINTED          48180000
*                   (ALSO POSSIBLY DISPLACED 1 TO THE LEFT)             48510000
*                                                                       48840000
         LA    2,TBSTRING+7        FIND LEFTMOST SIGNIFICANT DIGIT      49170000
         CLI   TBSTRING+7,X'FC'    (EXCEPT FOR 0.0, ALL VALUES ARE      49500000
*                                  AT LEAST 16 DIGITS)                  49830000
         BNE   TBFLT4              POSITION 7                           50160000
         LA    2,1(2)              POSITION 8                           50490000
         BCTR  3,0                 EXPONENT IS DOWN 1, TOO.             50820000
TBFLT4   SH    3,QH84              REMOVE EXCESS 100 ADJUSTED FOR SCALE 51150000
         LR    4,2                 RIGHTMOST SIGNIFICANT DIGIT IS       51480000
         A     4,OSIGDIG                                                51810000
         BCTR  4,0                 (OSIGDIG-1) FROM LEFTMOST            52140000
         LR    5,2                 ASSUME DECIMAL POINT FOLLOWS LEFT-   52470000
         CLI   WIDTH+1,X'FF'       MOST DIGIT (E-FORMAT)                52800000
*              SEPARATE CASES OF FORMATTING                             53130000
         BE    TBFLT10             E-FORMAT MATRIX                      53460000
*              F-FORMAT MATRIX OR FREE-FORMAT VECTOR                    53790000
         MVI   IR,0                ASSUME VECTOR NOT IN RANGE           54120000
*                                  (CALLER GUARANTEES MATRIX IN RANGE)  54450000
         CLI   WIDTH+3,0           PREPARE TO LOCATE THE DECIMAL POINT  54780000
         BNE   TBFLT6              MATRIX OUTPUT.  POINT IS AT LSIG+EXP 55110000
         CH    3,QHM4              VECTOR OUTPUT.  POINT IS AT LSIG+EXP 55440000
         BL    TBFLT7              ONLY IF EXP IS IN RANGE.             55770000
         C     3,OSIGDIG                                                56100000
         BNL   TBFLT7              EXPONENT GREATER THAN NO. OF SIG DIG 56430000
TBFLT6   AR    5,3                 EXPONENT IN RANGE.                   56760000
         MVI   IR,X'FF'            INHIBIT EXPLICIT EXPONENT            57090000
TBFLT7   CR    4,5                 DELETE TRAILING ZEROS                57420000
         BNH   TBFLT8              RIGHT OF THE DECIMAL POINT.          57750000
         CLI   0(4),X'F0'          IS RIGHTMOST A ZERO --               58080000
         BNE   TBFLT8              NO.  QUIT NOW.                       58410000
         BCT   4,TBFLT7            DROP RSIG AND CHECK NEXT DIGIT       58740000
TBFLT8   MVI   1(4),X'FC'          BLANK ALL DIGITS TO RIGHT OF RSIG    59070000
         MVC   2(20,4),1(4)        PLUS SOME EXTRA TO SAVE CALCULATING  59400000
*                                  AN MVC COUNT                         59730000
         CR    5,2                 NEGATIVE IN-RANGE EXPONENT REQUIRES  60060000
         BNL   TBFLT9              LEADING ZEROS.                       60390000
         LR    2,5                 FROM POSITION LSIG (NOW = TO DECPT)  60720000
         LCR   1,3                 MOVE IN (-EXP) LEADING ZEROS (MAX 4) 61050000
         BCTR  1,0                                                      61380000
         EX    1,TBMVZR                                                 61710000
TBFLT9   LA    6,1(5)              COMPUTE LEFT END OF F-FORMAT FIELD   62040000
         SH    6,WIDTH             AS DECIMAL POINT POSITION + 1        62370000
         B     TBFLT11             MINUS DEC PT OFFSET FROM LEFT END    62700000
         SPACE 2                                                        63030000
*              E - FORMAT MATRIX.                                       63360000
TBFLT10  LR    6,2                 LEFT END OF FIELD IS LSIG-2          63690000
         SH    6,QH3               CARRIED AS TRUE VALUE - 1            64020000
*                                  DECIMAL POINT POSITION IS POSITION   64350000
*                                  OF LEFTMOST SIGNIFICANT DIGIT.       64680000
*              ATTACH MINUS SIGN AND DECIMAL POINT                      65010000
TBFLT11  BCTR  2,0                 CARRY LSIG AS TRUE VALUE - 1         65340000
         MVI   0(2),X'FC'          ASSUME VALUE IS POSITIVE             65670000
         LR    1,2                 R1 CALCULATES LEFT END OF FIELD      66000000
*                                  FOR VECTORS                          66330000
         TM    TBFLTW0,X'80'       IS VALUE NEGATIVE --                 66660000
         BZ    TBFLT12             NO.                                  66990000
         MVI   0(2),X'FA'          YES.  ATTACH SIGN.                   67320000
         BCTR  1,0                 MOVE POTENTIAL LEFT END OVER.        67650000
TBFLT12  CLI   WIDTH+3,0           IS THIS VECTOR OUTPUT --             67980000
         BNZ   TBFLT13                                                  68310000
         LR    6,1                 YES.  ESTABLISH LEFT END.            68640000
TBFLT13  CLR   5,4                 ATTACH DECIMAL POINT.                68970000
         BNL   TBFLT14             NO DECIMAL POINT IF BEYOND LAST      69300000
*                                  SIGNIFICANT DIGIT.                   69630000
         LR    1,5                 CALCULATE NO. OF CHARS LEFT OF       69960000
         LA    0,TBSTRING          DECIMAL POINT, WHICH MUST BE MOVED.  70290000
         SR    1,0                                                      70620000
         EX    1,TBMVLFT           OVERLAPPED MOVE LEFT                 70950000
         MVI   0(5),X'FB'          INSERT POINT IN VACATED POSITION     71280000
         BCTR  6,0                 ADJUST LEFT END OF DECIMAL POINT     71610000
TBFLT14  CLC   WIDTH+1(1),IR       ATTACH AN 'E' IF REQUESTED BY CALLER 71940000
         BL    TBFLT17             OR IF EXPONENT IS NOT IN F-FMT RANGE 72270000
         CVD   3,TBFLTW1           CONVERT EXPONENT                     72600000
         LA    1,TBFLTW1+2         ANTICIPATE ZERO EXPONENT             72930000
         MVC   TBFLTW1-1(7),EXPAT  EDIT IT TO LEADING E'S, 2 OR 1       73260000
         EDMK  TBFLTW1-1(4),TBFLTW1+6  DIGITS, AND 3 TRAILING BLANKS.   73590000
         BCTR  1,0                 ADDRESS THE TRAILING E               73920000
         BNM   TBFLT16             IS EXPONENT NEGATIVE --              74250000
         MVI   0(1),X'FA'          YES.  MOVE IN HIGH MINUS SIGN,       74580000
         BCTR  1,0                 ADDRESS NEW TRAILING E.              74910000
TBFLT16  MVC   1(5,4),0(1)         INSERT EXPONENT AND BLANKS IN FIELD. 75240000
         SR    4,1                 MOVE RIGHTMOST SIGNIFICANT ADDRESS   75570000
         LA    1,TBFLTW1+3         OVER BY LENGTH OF EXPONENT,          75900000
         AR    4,1                 IGNORING TRAILING BLANKS.            76230000
*              PREPARE TO SEND CONVERTED STRING TO OUTPUT BUFFER        76560000
TBFLT17  LR    1,6                 FINAL ADDRESS OF LEFT END OF FIELD   76890000
*              REENTRY FROM INTEGER CONVERSION ROUTINE                  77220000
TBX      SR    4,1                 LENGTH IS RIGHTMOST SIGNIFICANT      77550000
         CLI   WIDTH+3,0           MINUS (LEFT END - 1)                 77880000
         BE    TBFLT18             FOR VECTORS,                         78210000
         LH    4,WIDTH+2           CALLER'S FIELD WIDTH FOR MATRICES.   78540000
         LR    1,6                 SUPERFLUOUS FOR MATRIX OUTPUT        78870000
TBFLT18  EX    4,TSTUFTR           TRANSLATE OUTPUT TO Z-SYMBOLS        79200000
         STC   4,0(1)              INSERT TRUE COUNT                    79530000
         ICALL SQUIRT              AND SQUIRT FIELD INTO BUFFER.        79860000
         LM    4,6,TBCDRSV                                              80190000
         IRETURN                                                        80520000
TSTUFTR  TR    0(0,1),TSTUFTT                                           80850000
TSTUFTT  EQU   *-C'0'                                                   81180000
         DC    AL1(Z0)                                                  81510000
         DC    AL1(Z1)                                                  81840000
         DC    AL1(Z2)                                                  82170000
         DC    AL1(Z3)                                                  82500000
         DC    AL1(Z4)                                                  82830000
         DC    AL1(Z5)                                                  83160000
         DC    AL1(Z6)                                                  83490000
         DC    AL1(Z7)                                                  83820000
         DC    AL1(Z8)                                                  84150000
         DC    AL1(Z9)                                                  84480000
         DC    AL1(ZOVB)           FA                                   84810000
         DC    AL1(ZPER)           FB                                   85140000
         DC    AL1(ZBLANK)         FC                                   85470000
         DC    AL1(ZE)             FD                                   85800000
TBDIV    DD    0,0(4)              SINGLE PRECISION DIVIDE              86130000
         BR    2                                                        86460000
TBMUL    MDR   0,6                 SINGLE PRECISION MULTIPLY            86790000
         BR    2                                                        87120000
TBMVLFT  MVC   TBSTRING(0),TBSTRING+1                                   87450000
TBMVZR   MVC   0(0,2),TBZROS                                            87780000
TBZROS   DC    C'0000'                                                  88110000
EXPAT    DC    X'FD202120FCFCFC'   LEADING E'S, TRAILING BLANKS         88440000
QHM4     DC    H'-4'                                                    88770000
QH3      DC    H'3'                                                     89100000
QH6      DC    H'6'                                                     89430000
QH84     DC    H'84'                                                    89760000
QH100    DC    H'100'                                                   90090000
QF1E8    DC    F'1E8'                                                   90420000
DRND     DC    E'5E14,5E13,5E12,5E11,5E10,5E9,5E8,5E7,5E6,5E5,5E4,5E3,5X90750000
               E2,5E1,5E0,5E-1'                                         91080000
D1016    DC    D'1E16'                                                  91410000
D106     DC    D'1E6'                                                   91740000
D10      DC    D'10'                                                    92070000
QBSD     DC    X'531834A1' 1E5 * 16**14 - 5E19 BIG SCALEDOWN THRESHOLD  92400000
QSSD     DC    X'4EFE3940' 16**14 - 5E15       SMALL SCALEDOWN  ''      92730000
QBSU     DC    X'4A10A92A' 16**14 / 1E6 - 5E8  BIG SCALEUP      ''      93060000
QSSU     DC    X'4E196C20' 16**14 / 10 - 5E13  SMALL SCALEUP    ''      93390000
         LTORG                                                          93720000
TOBCDWK  DSECT                                                          94050000
TBFLTW0  DS    D                   FLOATING HEX VALUE, SAVED FOR SIGN   94380000
TBFLTW1  DS    D                                                        94710000
TBFLTW2  DS    D                                                        95040000
WIDTH    DS    4F                  CONTROL INFORMATION PARAMETER        95370000
TBCDRSV  EQU   WIDTH+4                                                  95700000
IR       DS    XL1                                                      96030000
TBFILL   DS    XL12                LEADING BLANKS FOR TBSTRING          96360000
TBSTRING DS    CL44                OUTPUT STRING, PLUS 20 EXTRA PLACES  96690000
*                                  TO SAVE CALCULATING AN MVC COUNT     97020000
TOBEND   EQU   *                                                        97350000
         END                                                            97680000
./  ADD    NAME=APLSTPIN
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00020000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00040000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00060000
         PRINT OFF                                                      00080000
TPIN     TITLE 'S T A T E M E N T   I N P U T   A N D   F U N C T I O NX00100000
                  D E F I N I T I O N'                                  00120000
         PRINT ON                                                       00140000
         MACRO                                                          00160000
&L       CMD   &CMD,&ADR,&N,&FLAGS                                      00180000
         LCLA  &I                                                       00200000
         LCLC  &CHAR                                                    00220000
&L       DC    0F'0'                                                    00240000
         AIF   (&I EQ &I).CM1           APL DEVELOPMENT GLITCH          00260000
.CM1     ANOP                                                           00280000
&I       SETA  &I+1                                                     00300000
&CHAR    SETC  '&CMD'(&I,1)                                             00320000
         DC    AL1(Z&CHAR)                                              00340000
         AIF   (&I LT K'&CMD).CM1                                       00360000
&I       SETA  4-K'&CMD                                                 00380000
         DC    &I.AL1(0)                                                00400000
         DC    AL2(&ADR-SYSTO)                                          00420000
         DC    AL1(&N)                                                  00440000
         DC    AL1(&FLAGS)                                              00460000
         MEND                                                           00480000
         SPACE 1                                                        00500000
         MACRO                                                          00520000
&QZ      SCANT &X                                                       00540000
         ORG   SCANT+4+(Z&QZ-ZPER)*2                                    00560000
         DC    Y(&X-IDL)                                                00580000
         MEND                                                           00600000
         SPACE 1                                                        00640000
TYPEIN   CSECT                                                          00680000
         COPY  APLDEFN                                                  00700000
         COPY  ZSYMBOLS                                                 00720000
         COPY  PERTERM                                                  00740000
         EJECT                                                     2230 00760000
         APLSUPC ,                 MAPS SUPPARS AREA IN APLSUP     2230 00780000
VALCON   EQU   0                   AVOIDS ASM ERROR                2230 00800000
         PRINT OFF                                                      00820000
         TITLE 'S T A T E M E N T   I N P U T   A N D   F U N C T I O NX00840000
                  D E F I N I T I O N'                                  00860000
         PRINT NOGEN,ON                                                 00880000
         EJECT                                                          00900000
         ENTRY DPDIV                                                    00920000
         ENTRY DPMUL                                                    00940000
         EXTRN COPYID                                                   00960000
         EXTRN DIREMP                                                   00980000
         EXTRN DISPLAY                                                  01000000
         EXTRN DSIRMSG             'IMPROPER REFERENCE TO PRIVATE LIB'  01020000
         EXTRN FETCH                                                    01040000
         EXTRN GCOL                                                     01060000
         EXTRN GETIME                                                   01080000
         EXTRN GETSPACE                                                 01100000
         EXTRN KMANHASH                                                 01120000
         EXTRN LOUT                                                     01140000
         EXTRN LOUTI                                                    01160000
         EXTRN LOUTN                                                    01180000
         EXTRN MKGARB                                                   01200000
         EXTRN PLINE                                                    01220000
         EXTRN PRNUM                                                    01240000
         EXTRN SUPPARS             MAPPED BY SUPPARD DSECT         2230 01260000
         EXTRN PRWSNAME                                                 01280000
         EXTRN SOOKEXTX                                                 01300000
         EXTRN SOOKTXT             SEP ASSEMBLY FOR EASY MODIFICATION   01320000
         EXTRN SQUIRT                                                   01340000
         EXTRN SYNTXX                                                   01360000
         EXTRN TOBCD                                                    01380000
         EXTRN TOPRINT                                                  01400000
         EXTRN WSLEN                                                    01420000
         EXTRN ZSYMDATE            DATE STORED IN ZSYMBOLS              01440000
CLEOS    EQU   ZLEOS*2+1                                                01460000
CEOS     EQU   ZEOS*2+1                                                 01480000
CREM     EQU   ZREM*2+1                                                 01500000
CDUM     EQU   ZDUM*2+1                                                 01520000
CECONST  EQU   ZECONST*2+1                                              01540000
CBCONST  EQU   ZBCONST*2+1                                              01560000
CICONST  EQU   ZICONST*2+1                                              01580000
CFCONST  EQU   ZFCONST*2+1                                              01600000
CCCONST  EQU   ZCCONST*2+1                                              01620000
CCOMMA   EQU   ZCOMMA*2+1                                               01640000
CLARROW  EQU   ZLARROW*2+1                                              01660000
CSEMIC   EQU   ZSEMIC*2+1                                               01680000
*                                                                       01700000
*        A NOTE ON KLUGEY TREATMENT OF MX, TOCORG, AND TOCPTR           01720000
*                                                                       01740000
*        DURING EXECUTION, THE LOWER BOUNDARY OF THE GARBAGE BETWEEN    01760000
*        LOW M AND HIGH M IS ALWAYS ADDRESSED BY MX.                    01780000
*        THIS IS NOT SO IN TYPEIN.  MX NORMALLY IS NOT MOVED UNTIL A    01800000
*        COMPLETE, ERROR-FREE CODESTRING HAS BEEN BUILT ABOVE MX,       01820000
*        ADDRESSED BY TOCORG AND TOCPTR.  THIS GENERALLY CAUSES NO      01840000
*        TROUBLE.  UNFORTUNATELY, ANY INPUT OR OUTPUT REQUESTED WHILE   01860000
*        SUCH A CODESTRING IS BEING BUILT MAY RESULT IN LOSS OF THE     01880000
*        CODESTRING (IF I/O CAUSES SUSPENSION CAUSING WORKSPACE TO BE   01900000
*        WRITTEN TO DISK.)  MX CANNOT BE USED AS A RUNNING INDEX TO THE 01920000
*        NEW CODESTRING, BECAUSE IN THE EVENT OF AN ERROR (OR ANYTHING  01940000
*        ELSE WHICH WOULD INTERRUPT NORMAL PROCESSING) MX WOULD NOT BE  01960000
*        RESET TO ITS ORIGINAL VALUE, AND WE WOULD HAVE A CODESTRING    01980000
*        FRAGMENT DRIFTING AROUND IN M, WREAKING HAVOC AND MINOR NUI-   02000000
*        SANCE.  SO, MX MUST BE LEFT AT THE BASE OF THE CODESTRING      02020000
*        UNTIL WE ARE SURE IT IS A GOOD CODESTRING (AT CRL, Q.V.)       02040000
*        TO GET AROUND ALL OF THIS, INLINE (OR ITS CALLER, NAMELY       02060000
*        EOBSUB) ALWAYS SETS MX TO THE VALUE OF THE CODESTRING POINTER  02080000
*        BEFORE ALLOWING ANY I/O, AND RESTORES MX TO THE VALUE OF THE   02100000
*        CODESTRING ORIGIN IMMEDIATELY FOLLOWING THE TYI SEQUENCE.      02120000
*                                                                       02140000
*        A SIMILAR NOTE ON TREATMENT OF SVI AND SVIT                    02160000
*                                                                       02180000
*        FOR REASONS EXPLAINED ABOVE, SVI ALWAYS POINTS TO THE LOWEST   02200000
*        LOCATION IN USE BELOW EXECUTION STACK. AT ENTRY TO TYPEIN,     02220000
*        THIS IS (OR SHOULD BE) PARREL-4.  HOWEVER, M-ENTRIES FOR NEW   02240000
*        LONG PRINTNAMES ARE BUILT WORKING DOWNWARD FROM SVI WHILE A    02260000
*        CODESTRING IS BEING BUILT WORKING UPWARD FROM MX.  SVI MUST    02280000
*        THEREFORE POINT TO THE LOWEST NEW M-ENTRY.                     02300000
*        AT END-OF-STATEMENT, WHEN THE CODESTRING IS COMPLETE, MX IS    02320000
*        SET ABOVE THE NEW PRINTNAMES AND GARBAGE IS COLLECTED, MOVING  02340000
*        THE PRINTNAMES DOWN BELOW MX WHERE THEY SHOULD BE.             02360000
*        IN FUNCTION DEFINITION, 12-BYTE ENTRIES FOR NEW OR FRACTIONAL  02380000
*        LINE NUMBERS ARE ALSO BUILT WORKING DOWNWARD FROM THE STACK.   02400000
*        THESE, HOWEVER, ARE ADDED ONLY AFTER THE GARBAGE COLLECTION AT 02420000
*        END-OF-STATEMENT, AND ALWAYS RESIDE ABOVE ANY NEW PRINTNAMES.  02440000
*        THIS IS IMPORTANT, BECAUSE IT MEANS THAT FRACTIONAL-LINE       02460000
*        ENTRIES DO NOT NEED TO CONTAIN STORAGE-ALLOCATION OVERHEAD.    02480000
*        THE VARIABLE SVIT (ALWAYS GEQ SVI) POINTS TO 4 BYTES BELOW THE 02500000
*        LOWEST FRACTIONAL-LINE ENTRY. IT IS DROPPED BY 12 EACH TIME A  02520000
*        NEW FRACTIONAL LINE IS ADDED.                                  02540000
*        THE PURPOSE OF ALL OF THIS IS TO ALLOW GARBAGE COLLECTIONS     02560000
*        DURING FUNCTION DEFINITION, SO THAT SOMEONE WITH A WSFULL      02580000
*        ERROR IN DEFINITION MODE CAN DELETE LINES UNTIL IT IS POSSIBLE 02600000
*        TO CLOSE THE FUNCTION.                                         02620000
*                                                                       02640000
*                                                                       02660000
*        CHECKS ARE MADE FOR ADEQUATE FREE SPACE WHEN BUILDING A CODE-  02680000
*        STRING (AT FREECH), FORMING AN M-ENTRY FOR A NEW LONG PRINT-   02700000
*        NAME (AT SRCHB), CLOSING A CODESTRING IN DEFINITION MODE (AT   02720000
*        CRL5), AND WHEN CLOSING A DEFINITION (AT CRL9A.)               02740000
*        EACH CHECK INCLUDES A CERTAIN MARGIN OF SAFETY                 02760000
*        FREECH HAS THE NARROWEST, SO THAT WSFULL ERRORS DETECTED       02780000
*        ELSEWHERE DO NOT PRECLUDE USER ATTEMPTS TO DELETE ITEMS.       02800000
*        CRL9A ALSO HAS A NARROW MARGIN BECAUSE DEFINITION CLOSING WILL 02820000
*        PROVIDE MORE FREE SPACE ANYWAY.  CRL5 AND SRCHB HAVE A         02840000
*        WIDER MARGIN SO THAT THERE IS ROOM LATER TO ENTER ANY LINE-    02860000
*        DELETIONS NECESSARY FOR CLOSING DEFINITION.                    02880000
*        DELL HAS THE WIDEST, TO AVOID OPENING A DEFINITION THAT CRL9A  02900000
*        WON'T LET US CLOSE.                                            02920000
*                                                                       02940000
*                                                                       02960000
TYPEIN   CSECT                                                          02980000
         BALR  PR,0                                                     03000000
         USING *,PR                                                     03020000
TYPTOP   LA    10,4095(PR)                                              03040000
         USING TYPTOP+4095,10                                           03060000
         LA    9,4095(10)                                               03080000
         USING TYPTOP+2*4095,9                                          03100000
         L     LR,=A(WSLEN)        ESTABLISH R13 STACK                  03120000
         L     LR,0(LR)            FROM KNOWN, RELIABLE QUANTITIES      03140000
         S     LR,F103             CONTAINED IN READ-ONLY STORAGE.      03160000
         ST    LR,QR13STK          ENSURE CORRECT COPY IN M, TOO        03180000
         AR    LR,MR                                                    03200000
         USING PREPLOC,LR                                               03220000
         XC    PREPLOC(16),PREPLOC CLEAR 'PROLOG' REG SAVE AREA FOR SUP 03240000
         LA    TLR,(PREPLEND-PREPLOC+7)/8*8(LR)                         03260000
         MVI   BAKTOG,X'80'        SET FLAG TO INDICATE THAT CONTROL IS 03280000
*                                  IN TYPEIN INSTEAD OF SYNT.           03300000
         XC    TUSR(QUADTOG+1-TUSR),TUSR CLEAR A NUMBER OF TOGGLES      03320000
         SPACE 2                                                        03340000
*              REENTRY FROM SUCCESSFUL )LOAD                            03360000
*              WHICH MUST NOT ASSUME ANYTHING ABOUT VALUES IN TYPEIN'S  03380000
*              DSECT OR ABSOLUTE ADDRESSES (OF LOCATIONS IN THE INTER-  03400000
*              PRETER) IN M.                                            03420000
         SPACE 2                                                        03440000
TYPIN4   ON    DZ                  SET ALL ON-CONDITIONS TO DEFAULT     03460000
         ON    RNG                                                      03480000
         ON    XDZ                                                      03500000
         ON    XOF                                                      03520000
         ON    ATTN                                                     03540000
         ON    FP,ICVRER           ENABLE FLOATING TRAP                 03560000
         MVC   DMASK(12),DTOPS     MOVE HIGH ENDS OF UNNORMALIZED       03580000
*                                  FLOATING CONSTS TO R13 AREA          03600000
         L     1,MPTBASE                                                03620000
         TM    IOB1-PERTERM(1),NSIGNM  BYPASS SVI-SETTING IF NOT SIGNED 03640000
         BZ    TYPIN4B             ON -- SVI ADDRESSES PERLIB TABLE     03660000
         LM    1,2,MX ,SVI         AVOID SYS ERROR IF CHAR ERROR ON     03680000
         ST    1,MING              SIGNON                               03700000
         B     TYPIN5                                                   03720000
TYPIN4B  MVC   TLGCPTR,LGCPTR      FOR QUAD-PRIME INPUT OUTPUT-IGNORE   03740000
         L     2,PARREL            SET QUAD AND QUAD-PRIME FLAGS        03760000
         AR    2,MR                                                     03780000
         MVC   QUADTOG(1),STFLAGS(2)                                    03800000
         OI    STFLAGS(2),STIMBIT  TURN ON IMMEDIATE-EXECUTION TOGGLE   03820000
         NI    STFLAGS(2),255-STSTBIT  AND RESET 'COMPLETE STATEMENT'   03840000
         TM    QUADTOG,STQBIT+STQPBIT                                   03860000
         BO    TYPIN4A             IF NOT QP INPUT,                     03880000
         ICALL LOUTI               FORCE OUT ANY REMAINING OUTPUT       03900000
TYPIN4A  EQU   *                                                        03920000
         SPACE 2                                                        03940000
*              REENTRY FROM FUNCTION-DEFINITION CLOSE                   03960000
         SPACE 2                                                        03980000
TYPIN3   L     1,MINGL                                                  04000000
         BXLE  1,1,TYPIN2                                               04020000
         ICALL GCOL                                                     04040000
         SPACE 2                                                        04060000
*              REENTRY FROM SIGNON AND SOME EDITING ERRORS              04080000
*              AS WELL AS MOST COMMANDS IF NOT IN DEFINITION MODE       04100000
*                                                                       04120000
TYPIN2   L     2,PARREL                                                 04140000
         LA    4,STCODE(2,MR)      CLEAR REMAINS OF IMMEDIATE-          04160000
         XC    0(4,4),0(4)         EXECUTION STATEMENT FROM STACK       04180000
*                                  CLEAR FUNCTION DEFINITION POINTERS   04200000
ZDFNPTR  XC    DFNPTR(PROTOG+1-DFNPTR),DFNPTR+0*(FDTOG-PINAB)           04220000
*                                  AND TOGGLES                          04240000
INITHOFL MVC   HOFLN(LF108+4-HOFLN),HOFLSET   INITIALIZE           3034 04260000
*                                  FRACTIONAL-LINE-NUMBER LIST     3034 04280000
*                                  AND M-RELATIVE ENDING FLAG           04300000
         A     2,QFM4                                                   04320000
         ST    2,SVI               SET SVIT AND SVI FOR STORING PNAMES  04340000
TYPIN5   ST    2,SVIT              AND FRACTIONAL-LINE-NO ENTRIES       04360000
         B     BEGST2              NO LINE NUMBER IN IM-EX MODE         04380000
         SPACE 2                                                        04400000
*              REENTRY FROM END-OF-STATEMENT PROCESSING IN DEFINITION   04420000
*              MODE                                                     04440000
         SPACE 2                                                        04460000
BEGST1   TM    DPYTOG,DPYNMT       UPDATE THE LINE NUMBER UNLESS        04480000
         BZ    BEGST2              LINE WAS EMPTY (AND NO DELETION)     04500000
         LA    LKR,BEGST2          EASIER THAN SHUFFLING CARDS          04520000
*                                                                       04540000
*              SUBROUTINE TO                                            04560000
*              ADD ONE TO LOW-ORDER NON-ZERO FRACTION DIGIT OF LINE NO. 04580000
UPLINE   L     2,FLINENO                                                04600000
         CVD   2,DLINENO           GET THE LINE NUMBER IN DECIMAL       04620000
         LA    4,WPAT              FOR EDIT OPERATION.                  04640000
         LR    1,4                                                      04660000
         MVC   WPAT(9),LINPAT      MOVE EDIT PATTERN TO WORK AREA       04680000
         EDMK  WPAT(9),DLINENO+5   PUT IN R1 THE ADDRESS OF THE RIGHT-  04700000
*                                  MOST NONZERO DIGIT POSITION IN THE   04720000
*                                  FRACTIONAL PART OF THE LINE NUMBER.  04740000
         SR    4,1                 R4 IS -2 * DECIMAL PLACE             04760000
         AR    4,4                 MAKE IT -4 TIMES                     04780000
         A     2,P10+16(4)         ADD IN POWER OF TEN                  04800000
         CL    2,QF108             UNLESS THIS TAKES NUMBER OVER 10,000 04820000
         BL    *+8                                                      04840000
         L     2,QF9S              IN WHICH CASE MAKE IT 9999.9999      04860000
         ST    2,FLINENO                                                04880000
         BR    LKR                                                      04900000
*                                                                       04920000
*              REENTRY FROM END-OF-STATEMENT PROCESSING ON EMPTY STATE- 04940000
*              MENT IN EXECUTION MODE                                   04960000
*                                                                       04980000
BEGST2B  EQU   *                                                        05000000
*                                                                       05020000
*              REENTRY FROM ALL ERRORS EXCEPT EDITING ERROR THAT CLOSES 05040000
*              DEFINITION, END-OF-STATEMENT PROCESSING ON EMPTY STATE-  05060000
*              MENT IN EXECUTION MODE, INITIAL ENTRY TO TYPEIN AT       05080000
*              SIGNON, AND SYSTEM COMMANDS IF IN FUNCTION DEFINITION    05100000
*                                                                       05120000
*              BEGIN PROCESSING NEXT LINE.                              05140000
BEGST2   L     1,MX                SET UP CODESTRING POINTERS           05160000
         LA    2,MCSORG-M(1)                                            05180000
         STM   1,2,TOCORG                                               05200000
         NI    QUADTOG,255-STREMBIT REMBIT MAY BE ON FROM PREVIOUS LINE 05220000
         BAL   LKR,INLINE          BRING IN NEXT INPUT LINE             05240000
         TM    QUADTOG,STQPBIT     VERY SPECIAL ACTION FOR QUAD-PRIME   05260000
         BO    QUADPL              WHICH ACCEPTS ENTIRE INPUT LINE      05280000
         AGO   .SOX1                                                    05300000
.SOX1    ANOP                                                       SOX 05340000
         BAL   LKR,SKBL            FIND FIRST SIGNIFICANT CHAR          05360000
         L     1,MPTBASE           IF WE'RE NOT SIGNED ON,              05380000
         TM    IOB1-PERTERM(1),NSIGNM                                   05400000
         BO    SOPROC              RECOGNIZE ONLY )NNNN AND )OPR        05420000
*                                                                       05440000
*        REENTRY AFTER SEEING DEL FNAME DELIMITER -- I.E, SHORT FORM OF 05460000
*              EDITING.                                                 05480000
BEGST4   MVI   DPYTOG,DPYNMT       CLEAR DISPLAY TOGGLE INITIALLY       05500000
         CLI   FDTOG,0             ARE WE IN FUNCTION-DEFINITION MODE - 05520000
         BE    BEGST7              NO.DON'T LOOK FOR LEFT BRACKET. P053 05540000
BEGST3   CLI   0(6),ZLBR           IS FIRST CHARACTER A LEFT BRACKET -- 05560000
         BNE   BEGST7              NO.  GO CHECK FOR SYSTEM COMMANDS.   05580000
*              LEFT BRACKET BEGINNING A STATEMENT SEEN.                 05600000
         BAL   LKR,SKBLI           BUMP INPUT POINTER PAST LBR          05620000
         MVI   DPYTOG,DPYNMT       ASSUME NO DISPLAY                    05640000
         MVC   DTEMP+4(4),FLINENO  SAVE THE LINE NUMBER TEMPORARILY     05660000
         CLI   0(6),ZQUAD          IS THE NEXT CHAR A QUAD --           05680000
         BNE   LBRL1               NO.  DISPLAY ONE LINE AT MOST.       05700000
         MVI   DPYTOG,DPYNMT+DPYALL+DPYPAST  YES.  DISPLAY ENTIRE FUNCT 05720000
*                                  ION OR FN STARTING AT LINE N.        05740000
         BAL   LKR,SKBLI           SKIP PAST QUAD.                      05760000
LBRL1    BAL   LKR,INFLT           CONVERT THE LINE COUNTER             05780000
         DC    Y(FNERR-TYPTOP,LBRL3-TYPTOP)  IF ANY AND IF IN RANGE,    05800000
         DC    2Y(D10000-TYPTOP)   TO 'MIDPOINT' DECIMAL FIXED          05820000
         NI    DPYTOG,255-DPYALL   CANNOT BE A 'DISPLAY ALL'.           05840000
         BAL   LKR,SKBL                                                 05860000
         CLI   0(6),ZQUAD          IS CHARACTER FOLLOWING NUMBER        05880000
         BNZ   LBRL2               A QUAD --                            05900000
         TM    DPYTOG,DPYPAST      YES.  DID WE SEE A QUAD BEFORE --    05920000
         BO    FNERR               YES.  EDITING ERROR.                 05940000
         OI    DPYTOG,DPYLIN       SET 'DISPLAY LINE' TOGGLE            05960000
         BAL   LKR,SKBLI           LOOK AT CHARS FOLLOWING QUAD         05980000
         BAL   LKR,ININT           IS THERE AN INTEGER --               06000000
         DC    Y(FNERR-TYPTOP,LBRL2-TYPTOP)                             06020000
         MVI   DPYTOG,DPYNMT+DPYLIN+DPYED  YES.  CHAR EDIT REQUEST.     06040000
         STH   3,INBUF-2           SAVE START COLUMN FOR EDITING        06060000
         BAL   LKR,SKBL                                                 06080000
LBRL2    CLI   0(6),ZRBR           IS NEXT CHARACTER A RIGHT BRACKET -- 06100000
         BNE   FNERR               NO.  FUNCTION ERROR.                 06120000
         MVC   FLINENO(4),DTEMP+4  ALL OK.  SAVE LINE NUMBER IN FLINENO 06140000
         BAL   LKR,SKBLI                                                06160000
         B     BEGST3              AND LOOK FOR ANOTHER LBR OR STMT     06180000
LBRL3    TM    DPYTOG,DPYALL       NO LINE NUMBER.  HAVE WE SEEN A QUAD 06200000
         BZ    FNERR               NO.  EDITING ERROR.                  06220000
         B     LBRL2                                                    06240000
BEGST7   TM    DPYTOG,DPYLIN+DPYPAST  SINGLE OR MLTPL LINE DISPLAY?P053 06260000
         BZ    BEGST9              NO.                             P053 06280000
         CLI   PROTOG,0            REQUEST TO DISPLAY A            P053 06300000
         BNE   FNERR               LOCKED FUNCTION IS AN ERROR.    P053 06320000
         CLI   0(6),ZCR            DISPLAY OR EDIT REQUEST FOLLOWEDP053 06340000
         BE    BEGST9              BY AN EMPTY LINE IS OK.         P053 06360000
         TM    DPYTOG,DPYED        EDIT REQUEST FOLLOWED BY        P053 06380000
         BO    FNERR               A NON-EMPTY LINE IS AN ERROR.   P053 06400000
         CLI   0(6),ZDEL           DISPLAY REQUEST FOLLOWED        P053 06420000
         BE    BEGST9              BY A DEL OR                     P053 06440000
         CLI   0(6),ZPDEL          A PDEL IS OK.                   P053 06460000
         BNE   FNERR               ALL ELSE IS AN ERROR.           P053 06480000
BEGST9   CLI   0(6),ZRPAR          IS THIS A SYSTEM COMMAND --          06500000
         BE    SYSCMD              YES.                                 06520000
         CLI   0(6),ZREM           NO.  IS IT A COMMENT LINE --         06540000
         BE    REML                YES.  TREAT LIKE QUAD-PRIME.         06560000
         LA    2,CEOS              EVERY STATEMENT BEGINS WITH AN END-  06580000
*                                  OF-STATEMENT SYLLABLE.               06600000
*              ENTRY FOR CALLING TOCODE1 AND SCANNING THIS CHARACTER    06620000
TOCAST   BCT   6,SCANA             OFF TO BUILD A CODESTRING.           06640000
LINPAT   DC    X'202220222022202220'                                    06660000
*                                                                       06680000
*              PUT A 1-BYTE SYLLABLE INTO THE CODESTRING                06700000
TOCODE1  L     1,TOCPTR                                                 06720000
         STC   2,M(1)              STORE R2 AT CURRENT ADDRESS          06740000
         LA    1,1(1)              AND UPDATE ADDRESS.                  06760000
         B     TOCOM                                                    06780000
*                                                                       06800000
*              PUT A 2-BYTE SYLLABLE INTO THE CODESTRING                06820000
TOCODE2  L     1,TOCPTR                                                 06840000
         STC   2,M+1(1)            STORE LOW R2 1 BEYOND CURRENT ADDR   06860000
         SRL   2,8                                                      06880000
         STC   2,M(1)              AND HIGH R2 AT CURRENT ADDRESS       06900000
         LA    1,2(1)              UPDATE CODE ADDRESS BY 2             06920000
TOCOM    ST    1,TOCPTR                                                 06940000
*                                                                       06960000
*              CHECK FOR POSITIVE AMOUNT OF FREE STORAGE                06980000
*              BETWEEN TOCPTR AND SVIT.                                 07000000
*              FREECH USES ONLY R0.                                     07020000
FREECH   LA    0,20                REQUIRE 20 BYTES SLOP                07040000
FREECH1  A     0,TOCPTR                                                 07060000
FREECH2  C     0,SVI                                                    07080000
         BCR   12,LKR                                                   07100000
         BAL   8,RELPNS            STORAGE MAY NOT BE COMPACT, AND      07120000
*                                  THERE MAY BE LONG PRINTNAMES AT SVI  07140000
TROUBLE  L     4,MPTBASE           IF WE'RE BEING FORCED OFF, DON'T     07160000
         TM    IOB2-PERTERM(4),BOUNCM MINDLESSLY REPEAT 'WS FULL'       07180000
         BO    CMCLEAR             DESTROY THIS WORKSPACE               07200000
         BAL   1,PPERR             WS FULL ERROR                        07220000
         DC    AL1(7,ZW,ZS,ZBLANK,ZF,ZU,ZL,ZL)                          07240000
*                                                                       07260000
*              SKIP BLANKS AND EOB'S IN INPUT.                          07280000
SKBLI    LA    6,1(6)              ENTRY TO PREBUMP INPUT POINTER       07300000
SKBL     CLI   0(6),ZBLANK                                              07320000
         BE    SKBLI                                                    07340000
         CLI   0(6),ZEOB                                                07360000
         BCR   7,LKR                                                    07380000
         STM   LKR,5,SKBTEMP       INLINE USES 0 THROUGH 6              07400000
         BAL   LKR,EOBSB2                                               07420000
         LM    LKR,5,SKBTEMP                                            07440000
         B     SKBL                                                     07460000
*                                                                       07480000
*              EOB BEFORE CR SEEN.                                      07500000
EOBL     LA    LKR,SCAN            IGNORE EOB EXCEPT TO FETCH CONTINUA- 07520000
         BCTR  6,0                 TION OF STATEMENT.                   07540000
*                                                                       07560000
*              CHECK FOR EOB AND FETCH NEW LINE IF PRESENT              07580000
EOBSUBI  LA    6,1(6)              ENTRY TO PREBUMP INPUT POINTER       07600000
         CLI   0(6),ZEOB           IS THIS CHARACTER AN EOB --          07620000
         BCR   7,LKR               NO.  RETURN IMMEDIATELY              07640000
EOBSB2   TM    COPTOG,COPIBIT      IF WE'RE A COPY SINK,                07660000
EOBSB3   ST    LKR,INLINK          OR AN OPEN QUOTE WHICH ENTERS HERE,  07680000
         EX    0,INLINX            GET NEXT LINE WITH NO INTERVENING    07700000
         BO    TYI                 OUTPUT OF SIX SPACES.                07720000
*                                  FOR 1050'S (ALMOST EXCLUSIVELY),     07740000
         ICALL LOUT                FORCE OUT THE OUTPUT BUFFER          07760000
         B     INLINB              AND ASK FOR MORE TEXT.               07780000
         SPACE 2                                                        07800000
ININT    ST    LKR,ININTMP         SCAN AND CONVERT INTEGER CONSTANT.   07820000
         MVI   ICVFG,0             RESET ICV FLAGS                      07840000
         BAL   LKR,ICV             CONVERT ONE CONSTANT                 07860000
         L     LKR,ININTMP                                              07880000
         LH    2,0(LKR)            RETURN THROUGH 0(LKR) IF NOT GOOD    07900000
         TM    ICVFG,FLBIT         INTEGER                              07920000
         BNZ   TYPTOP(2)                                                07940000
         LH    2,2(LKR)            RETURN THROUGH 2(LKR) IF NO CONSTANT 07960000
         TM    ICVFG,QUBIT         AT ALL                               07980000
         BO    TYPTOP(2)                                                08000000
         B     4(LKR)              OTHERWISE RETURN TO 4(LKR)           08020000
         SPACE 2                                                        08040000
INFLT    ST    LKR,ININTMP         SCAN AND CONVERT FLOATING CONSTANT.  08060000
         MVI   ICVFG,FLBIT         FORCE FLOATING TYPE                  08080000
         BAL   LKR,ICV             CONVERT                              08100000
         L     LKR,ININTMP         RESTORE LINK                         08120000
         LH    1,2(LKR)            NO-CONSTANT EXIT                     08140000
         TM    ICVFG,QUBIT                                              08160000
         BO    TYPTOP(1)                                                08180000
         LH    1,0(LKR)            RANGE ERROR EXIT                     08200000
         AR    1,PR                 PR = TYPTOP                         08220000
         LTER  0,0                 CONSTANT MUST BE NONNEGATIVE         08240000
         BCR   4,1                                                      08260000
         LH    2,4(LKR)            MAX VALUE                            08280000
         CD    0,0(2,PR)                                                08300000
         BCR   11,1                TOO BIG                              08320000
         LH    2,6(LKR)            SCALE NUMBER BEFORE FIXING           08340000
         MD    0,0(2,PR)                                                08360000
         AD    0,ERND              ROUND TO NEAREST INTEGER             08380000
         AW    0,DUNZ                                                   08400000
         STD   0,DTEMP                                                  08420000
         B     8(LKR)              RETURN                               08440000
         EJECT                                                          08460000
*                                                                       08480000
*                                                                       08500000
*              THE NUMERIC INPUT CONVERSION ROUTINE                     08520000
*                                                                       08540000
*              TOGGLES USED BY NUMERIC CONVERSION                       08560000
FLBIT    EQU   1                   RESULT IS FLOATING POINT             08580000
DPBIT    EQU   2                   DECIMAL POINT SCANNED                08600000
EXBIT    EQU   4                   WE'RE WORKING ON DECIMAL EXPONENT    08620000
OVBIT    EQU   8                   OVERBAR SCANNED                      08640000
QUBIT    EQU   16                  QUIT BIT (USED BY NUML ONLY)         08660000
VEBIT    EQU   64                  WE'RE CATENATING CONSTANT VECTOR     08680000
ICV      NI    ICVFG,FLBIT+VEBIT   RESET RELEVANT INDICATORS            08700000
*              REENTRY TO CONVERT DECIMAL EXPONENT                      08720000
ICV3     CLI   0(6),ZOVB           IS FIRST CHARACTER AN OVERBAR --     08740000
         BNE   ICV0                NO.                                  08760000
         OI    ICVFG,OVBIT         YES.  RECORD FACT AND BUMP INPUT     08780000
         LA    6,1(6)              POINTER.                             08800000
ICV0     SR    4,4                 CLEAR WORKING REGISTERS              08820000
         LR    5,4                                                      08840000
         STM   4,5,HN                                                   08860000
*              R1 = CURRENT CHARACTER                                   08880000
*              R2,3 = DOUBLE REGISTER USED TO ACCUMULATE FRACTION       08900000
*              R4 = 0 - NUMBER OF DIGITS NOT CONVERTED TO THE LEFT OF   08920000
*                  THE DECIMAL POINT BECAUSE OF EXCESSIVE FRACTION      08940000
*                  (IRRELEVANT AFTER DECIMAL POINT IS SCANNED)          08960000
*              R5 = 0 - TOTAL NUMBER OF DIGITS SCANNED                  08980000
*              R7 = 0 - (NUMBER OF FRACTION DIGITS CONVERTED + R4)      09000000
*                  (RELEVANT ONLY AFTER DECIMAL POINT IS SCANNED)       09020000
ICV1     SR    1,1                 REENTRY FOR NEXT DIGIT               09040000
         IC    1,0(6)                                                   09060000
         S     1,QZ0               GET TRUE DIGIT                       09080000
         CL    1,QF9               IS IT INDEED A DIGIT --              09100000
         BNH   ICV2                YES.  ADD IT IN.                     09120000
         TM    ICVFG,DPBIT+EXBIT   ARE WE WORKING ON INTEGER PART --    09140000
         BNE   ICV7                NO.  DISCONTINUE CONVERSION.         09160000
         LCR   7,4                 R7 WILL BE EXPONENT OFFSET.          09180000
         CLI   0(6),ZPER           IS CURRENT CHARACTER A PERIOD --     09200000
         BNE   ICV7                NO.  NO FRACTIONAL PART.             09220000
         LA    6,1(6)              YES.  BUMP POINTER PAST IT           09240000
         OI    ICVFG,DPBIT         RECORD PERIOD                        09260000
         B     ICV1                AND CONTINUE CONVERSION.             09280000
ICV2     L     3,HN                PREPARE TO MULTIPLY HIGH-ORDER HALF  09300000
         CL    3,QFCVL             BY 10, PROVIDED MULTIPLY WILL NOT    09320000
         BL    ICV4                OVERFLOW.                            09340000
         BCT   4,ICV9              TOO MANY DIGITS.  BUMP LOST-DIGIT CT 09360000
ICV4     M     2,P10+4                                                  09380000
         LR    0,3                 SAVE HIGH PRODUCT                    09400000
         L     3,LN                MULTIPLY LOW-ORDER HALF              09420000
         LTR   3,3                                                      09440000
         M     2,P10+4             BY 10                                09460000
         BNM   ICV6                CORRECT HIGH-ORDER PRODUCT FOR       09480000
         AL    2,P10+4             INCORRECT MULTIPLY IF NEGATIVE.      09500000
ICV6     AR    2,0                 COMBINE HIGH-ORDER HALVES            09520000
         ALR   3,1                 ADD IN NEW DIGIT                     09540000
         BC    12,ICV5             PROPAGATE CARRY TO HIGH-ORDER HALF.  09560000
         AL    2,P10                                                    09580000
ICV5     BCTR  7,0                 BUMP CONVERTED-DIGIT COUNT.          09600000
         STM   2,3,HN              SAVE PARTIAL RESULT                  09620000
ICV9     LA    6,1(6)              BUMP INPUT POINTER TO NEXT CHAR      09640000
         BCT   5,ICV1              BACK FOR THE NEXT DIGIT              09660000
*              CONSTANT DELIMITER HAS BEEN SEEN                         09680000
ICV7     LTR   5,5                 DID 'NUMBER' CONTAIN ANY DIGITS --   09700000
         BZ    ICVER               NO.  ERROR.                          09720000
         LM    2,3,HN              RELOAD FRACTION (OR EXPONENT)        09740000
         TM    ICVFG,EXBIT         WERE WE WORKING ON FRACTION OR EXP - 09760000
         BO    ICV8                EXPONENT.                            09780000
         TM    ICVFG,DPBIT+FLBIT   FRACTION.  IS THIS TO BE MADE A      09800000
         BNE   ICV10               FLOATING-POINT NUMBER --             09820000
         CLI   0(6),ZE             YES, CERTAINLY, IF NEXT CHARACTER    09840000
         BE    ICV10               IS AN E.                             09860000
         LTR   2,2                 MAYBE NOT.  IS IT SMALL ENOUGH TO BE 09880000
         BNE   ICV10               AN INTEGER --                        09900000
         LTR   3,3                 MAYBE.  IT'S LESS THAN 2**32.        09920000
         BM    ICV10               NO.  IT'S MORE THAN 2**31-1.         09940000
         TM    ICVFG,OVBIT         YES.  CHECK FOR MINUS SIGN           09960000
         BZ    ICV17                                                    09980000
         LCR   3,3                                                      10000000
ICV17    ST    3,DTEMP                                                  10020000
         BR    LKR                                                      10040000
*                                                                       10060000
ICV10    OI    ICVFG,FLBIT         MAKE ALL FOLLOWING NUMBERS FLOATING. 10080000
         ST    2,DNASK+4           BEGIN FLOATING-POINT CONVERSION.     10100000
         ST    3,DMASK+4           MAKE FRACTION PARTS UNNORMALIZED     10120000
         ST    7,EN                FLOATING POINT.                      10140000
*                                  R7 = OFFSET FROM TEXT EXPONENT.      10160000
         SDR   0,0                 PUT PIECES OF FRACTION INTO FLOATING 10180000
         LD    2,DMASK             REGISTERS AND NORMALIZE THEM.        10200000
         ADR   2,0                                                      10220000
         AD    0,DNASK                                                  10240000
         TM    ICVFG,OVBIT         IF THERE WAS A PRECEDING OVERBAR,    10260000
         BZ    ICV15                                                    10280000
         XI    ICVFG,OVBIT                                              10300000
         LCER  0,0                 REVERSE THE SIGNS.                   10320000
         LCER  2,2                                                      10340000
ICV15    SR    3,3                                                      10360000
         CLI   0(6),ZE             IS NEXT INPUT CHARACTER AN E --      10380000
         BNE   ICV12               NO.  NO EXPONENT PART.               10400000
         LA    6,1(6)              YES.  BUMP POINTER PAST E            10420000
         OI    ICVFG,EXBIT         AND SET TO WORK CONVERTING EXPONENT. 10440000
         B     ICV3                                                     10460000
*              DELIMITER FOR EXPONENT HAS BEEN SEEN                     10480000
*        NOTES ON EXPONENT SIZE ..                                      10500000
*              EXPONENT OVERFLOW INTERRUPT WILL TERMINATE RUNAWAY       10520000
*              SCALE-UP LOOP.  CHECK FOR 100 GEQ ABS EXPONENT WILL      10540000
*              PREVENT SCALE-DOWN LOOP FROM RUNNING AWAY.  HERE WE MUST 10560000
*              MAKE SURE THAT EXPONENTS GTR 2*32 OR 'NEGATIVE' (BIT 0   10580000
*              OF R3 ON) ARE RECOGNIZED AS LARGE.  WE CAN'T MAKE A      10600000
*              REALLY NARROW BOUND ON SIZE BECAUSE WE HAVEN'T FIGURED   10620000
*              IN EN, WHICH INDICATES SCALING DUE TO TRAILING FRACTION  10640000
*              DIGITS AND DIGITS IGNORED AT ICV2.                       10660000
ICV8     CL    3,F104                                                   10680000
         BH    *+8                 EXPONENT  MOD 2*32 BIGGER THAN 10000 10700000
         BXLE  2,3,*+8             EXPONENT  LESS THAN 2*32             10720000
         L     3,F104              MAKE EXPOENENT NON-RIDICULOUSLY BIG. 10740000
         TM    ICVFG,OVBIT         GIVE EXPONENT PROPER SIGN            10760000
         BZ    ICV12                                                    10780000
         LCR   3,3                                                      10800000
*              FRACTION IS IN F0, F2                                    10820000
*              DECIMAL EXPONENT IS IN R3 + EN                           10840000
ICV12    LA    1,6                 SET UP BXLE LOOP FOR LARGE SCALING.  10860000
         LDR   4,0           *                                          10880000
         ADR   0,2           *     FIRST MOVE AS MUCH SIGNIFICANCE AS   10900000
         BZ    ICVSD               (NO SCALING FOR TRUE ZERO)           10920000
         SDR   4,0           *     POSSIBLE TO F0.                      10940000
         ADR   2,4           ******IMMUNE TO GUARD DIGIT (BYTE)         10960000
*                                  BECAUSE NO POSTNORMALIZATION AFTER   10980000
*                                  PRE-DENORMALIZATION EXCEPT ON        11000000
*                                  ADR  2,4  WHICH HAS PLENTY OF LOW-   11020000
*                                  ORDER ZEROS.                         11040000
         LCR   0,1                                                      11060000
         A     3,EN                COMBINE EXPONENT AND OFFSET          11080000
         ST    3,EN                SAVE FOR 16*14 SCALEDOWN AT ICVSN    11100000
         BP    ICVSU               SCALE UP IF POSITIVE.                11120000
         BZ    ICVSN               ZERO.  NO SCALING NEEDED.            11140000
         LCR   3,3                 TAKE ABSOLUTE VALUE OF EXPONENT      11160000
         C     3,F102              MIN 100 TO PREVENT EXTREMELY LONG    11180000
         BNH   *+8                 SCALING LOOPS.                       11200000
         LA    3,100                                                    11220000
         LA    3,7(3)              BUMP BY 1 FOR BCT LOOP               11240000
*                                  AND BY 7 FOR BXH LOOP.               11260000
         DD    0,D16M14            SCALE EXPONENTS UP TO AVOID UNDERFLW 11280000
         DD    2,D16M14            ON LOW-ORDER HALF IN EXTREME CASES   11300000
         LA    4,D106                                                   11320000
         BALR  2,0                 SET RETURN FOR DIVIDE                11340000
         BXH   3,0,ICVDIV          THE BIG SCALING LOOP                 11360000
         LA    4,D10                                                    11380000
         BALR  2,0                 THE LITTLE SCALING LOOP              11400000
         BCT   3,ICVDIV                                                 11420000
         B     ICVSN               SCALING DOWN ALL DONE.               11440000
DPDIV    EQU   *                   USED BY TOBCD                        11460000
ICVDIV   STD   0,0(TLR)            THE FANCY DOUBLE-PRECISION DIVIDE.   11480000
         DD    0,0(4)              OUTSIDE DIVIDE                       11500000
         SDR   6,6                                                      11520000
         LER   6,0                 COPY QUOTIENT TO F4 AND F6 IN TWO    11540000
         LCDR  4,6                 PIECES SO GENUINELY LOSING MULTIPLY  11560000
         ADR   4,0                 DOESN'T LOSE ANY SIGNIFICANCE.       11580000
         MD    4,0(4)              MULTIPLY PIECES BY 1E6 OR 10 .       11600000
         MD    6,0(4)                                                   11620000
         SD    6,0(TLR)            F6 HAS AT LEAST 2 TRAILING HEX ZEROS 11640000
         ADR   6,4                 AND EXPONENT DIFFERENCE IS 1 OR 0.   11660000
         SDR   2,6                 ADD TRUE FLOATING REMAINDER TO F2,   11680000
         DD    2,0(4)              FINALLY DIVIDE THE REMAINDER.        11700000
         BR    2                                                        11720000
DPMUL    EQU   *                   USED BY TOBCD                        11740000
ICVMUL   SDR   4,4                 THE FANCY 1.5-PRECISION MULTIPLY     11760000
         LCER  4,0                                                      11780000
         ADR   4,0                 F4 = LOW 32 BITS OF F0 FRACTION      11800000
         ADR   2,4                 KEEP 1-BITS OUT OF LOW F0 SO THAT    11820000
         SDR   0,4                 LOSING MULTIPLY DOESN'T DROP BITS    11840000
         MDR   0,6                                                      11860000
         MDR   2,6                                                      11880000
         BR    2                                                        11900000
ICVSU    LA    3,7(3)              BUMP BY 1 FOR BCT, 6 FOR BXLE.       11920000
         LD    6,D106              LOAD BIG SCALING CONSTANT            11940000
         BALR  2,0                                                      11960000
         BXH   3,0,ICVMUL          BIG SCALEUP                          11980000
         LD    6,D10                                                    12000000
         BALR  2,0                                                      12020000
         BCT   3,ICVMUL            SMALL SCALEUP                        12040000
ICVSN    LCDR  4,0                 NOW COMBINE FRACTION PARTS           12060000
         SDR   4,2                 WITH 'ROUNDED' ADDITION -- THAT IS,  12080000
         ADR   0,4                 ADD IN DOUBLE THE IGNORED LOW-ORDER  12100000
         ADR   0,2                 BITS.                                12120000
         AER   0,0                 IGNORED BITS SURELY FIT IN ONE WORD  12140000
         SDR   0,4                                                      12160000
         TM    EN,X'80'                                                 12180000
         BZ    ICVSD               IF SO, EXPONENT WAS SCALED UP BY     12200000
         DD    0,D1614             16*14 AND MUST BE SCALED DOWN.       12220000
ICVSD    STD   0,DTEMP             AND SAVE THE RESULT.                 12240000
         BR    LKR                 ALL CONVERTED.                       12260000
*                                                                       12280000
ICVER    TM    ICVFG,EXBIT         SYNTAX ERROR IN CONSTANT.            12300000
         BZ    ICVE2               WE WEREN'T IN THE EXPONENT.          12320000
         BCTR  6,0                 BACK UP TO E                         12340000
         TM    ICVFG,OVBIT         OR TO OVERBAR, IF PRESENT,           12360000
         BZ    ICVE1               IN WHICH CASE BACK UP AGAIN          12380000
         BCTR  6,0                                                      12400000
ICVE1    MVI   0(6),ZFE            PUT AN ILLEGAL E-PRINTING CHARACTER  12420000
         B     ICV15               IN CODESTRING AND FINISH             12440000
*                                  CONVERTING THE FRACTION.             12460000
ICVE2    OI    ICVFG,QUBIT         ILLEGAL FRACTION -- NO DIGITS.       12480000
         TM    ICVFG,OVBIT+DPBIT   TELL NUML TO QUIT, THEN BACK INPUT   12500000
         BCR   8,LKR               POINTER OVER NO, ONE, OR TWO CHARS.  12520000
         BCTR  6,0                                                      12540000
         BCR   4,LKR                                                    12560000
         BCTR  6,LKR               RETURN TO CALLER.                    12580000
*                                                                       12600000
ICVRER   STD   0,DTEMP             FLOATING TRAP IN SCALING.            12620000
         OC    DTEMP,INFIN         MAKE THE VALUE A SIGNED INFINITY     12640000
         LD    0,DTEMP                                                  12660000
         BR    LKR                                                      12680000
*                                                                       12700000
CEFNERR  LA    6,INBUF(5)          EDITING ERROR IN CHAR-EDIT MODE.     12720000
FNERR    BAL   1,PPERR             DEFN ERROR                           12740000
         DC    AL1(4,ZD,ZE,ZF,ZN)      'DEFN'                           12760000
CHERR    MVI   INTOG,0             RESET INLINE FLAGS                   12780000
         BAL   1,PPERR             CHARACTER ERROR.                     12800000
         DC    AL1(9,ZC,ZH,ZA,ZR,ZA,ZC,ZT,ZE,ZR)                        12820000
PPERR    ICALL SQUIRT                                              3574 12840000
         LA    1,ERTEXT            PRINT THE WORD 'ERROR'.         3574 12860000
PPERR2   LA    8,BEGST2            NORMAL EXIT ADDRESS.            3574 12880000
         NI    FDTOG,255-FDCLBIT   IGNORE POSSIBLE CLOSING DEL.    3574 12900000
         LA    5,INBUF             START OF LINE DISPLAY           3574 12920000
         SR    6,5                 LENGTH OF LINE DISPLAY.         3574 12940000
         ICALL SQUIRT                                              3574 12960000
         ICALL LOUT                                                3574 12980000
         LA    LKR,CHER3                                                13000000
         TM    COPTOG,COPIBIT      FOR SECURITY IN )COPY OPERATIONS,    13020000
         BZ    CHER2              IF ERROR OCCURRED DURING FN DEF, 3053 13040000
         B     ERFID               COMPLETELY UNDEFINE THE FUNCTION.    13060000
CHER2    STC   6,INBUF-1           LENGTH OF LINE DISPLAY.         3574 13080000
         LA    1,INBUF-1           START OF LINE DISPLAY.          3574 13100000
         SH    6,QH255             IF LENGTH IS LESS THAN 255,     3574 13120000
         BNP   PPERR3              PRINT IT NOW.                   3574 13140000
         MVI   INBUF-1,X'FF'       OTHERWISE PRINT THE LINE IN     3574 13160000
         ICALL SQUIRT              TWO PARTS.                      3574 13180000
         LA    1,INBUF-1+255       PRINT THE REST OF THE LINE.     3574 13200000
         STC   6,INBUF-1+255                                       3574 13220000
PPERR3   ICALL SQUIRT              DISPLAY THE LINE.               3574 13240000
         LA    1,CHIND             APPEND LINEFEED AND CARET            13260000
         ICALL SQUIRT                                                   13280000
         ICALL LOUT                                                     13300000
CHER3    TM    FDTOG,X'FF'-FDDHBIT ARE WE IN FN DEFINITION MODE?   3032 13320000
         BM    *+8                BR YES-CONTINUE WITH DEFINITION  3053 13340000
         LA    8,TYPIN2           NO-RETURN WILL BE TO EXEC MODE   3032 13360000
*              MUST NOT LEAVE FN DEFINITION MODE ONCE TRULY IN --       13380000
*              LONG PRINTNAMES, FRACTIONAL-LINE LIST, AND FUNCTION      13400000
*              DIRECTORY ARE IN AN ANOMALOUS STATE.                     13420000
*                                                                       13440000
*              RELOCATE LONG PRINTNAMES THAT MAY BE SITTING BETWEEN     13460000
*              SVI AND SVIT.  ALSO RESET SVI.                           13480000
*                        R8 = RETURN LINK                               13500000
RELPNS   L     1,MX                                                     13520000
         LCR   0,1                 TURN FREE M INTO A HUGE PIECE OF GAR 13540000
         A     0,SVI               BAGE.                                13560000
         S     0,QFM4              BYTE COUNT IS 4+SVI-MX               13580000
         ST    0,MCOUNT(1)                                              13600000
         AR    1,MR                MARK IT GARBAGE                      13620000
         MVI   MGARB-M(1),MGBIT                                         13640000
         L     1,SVIT              SET SVI ABOVE NEW PRINTNAMES.        13660000
*                                  IN EXECUTION MODE, THIS = PARREL-4   13680000
         ST    1,SVI               SET MX ABOVE NEW PRINTNAMES AND      13700000
         LA    1,4(1)              BELOW FRACTIONAL-LINE-NO ENTRIES     13720000
         ST    1,MX                SO GARBAGE COLLECTOR LOOKS AT ALL M  13740000
         ICALL GCOL                THE PAST IS PROLOGUE                 13760000
         BR    8                                                        13780000
CHIND    DC    AL1(2,ZLF,ZAND)                                          13800000
ERTEXT   DC    AL1(6,ZBLANK,ZE,ZR,ZR,ZO,ZR)                             13820000
*                                                                       13840000
*        ERASE FUNCTION IN DEFINITION                                   13860000
*              RETURN IS TO 0(LKR)                                      13880000
*              ON ENTRY, DFNPTR IS POINTER TO S.T. ENTRY, IF ANY        13900000
*              ON EXIT, R0 - R5, R8 DESTROYED                           13920000
ERF2     L     4,DFNPTR            MARK THE DIRECTORY, IF ANY, GARBAGE. 13940000
         LR    3,4                                                      13960000
         BAL   1,MKCSGI                                                 13980000
         EX    0,ZDFNPTR                                                14000000
*        ENTRY                                                          14020000
ERFID    TM    FDTOG,FDDFBIT       BYPASS COMPLETELY IF NOT IN          14040000
         MVI   FDTOG,0             FOR SAFETY                           14060000
         BCR   8,LKR               FUNCTION DEFINITION                  14080000
         BAL   8,LINIT             SET UP TO ERASE ALL LINES            14100000
ERF1     BAL   8,LINTRAC           LOCATE NEXT LINE                     14120000
         B     ERF2                OFF END OF FUNCTION                  14140000
         BAL   1,MKCSGI            MKCSGI CHECKS FOR EXISTENCE OF LINE  14160000
         B     ERF1                                                     14180000
         EJECT                                                          14200000
*                                                                       14220000
*              THE CENTRAL INPUT SCANNER                                14240000
*                                                                       14260000
SCANA1   LA    2,1(2,2)            TURN ZSYMBOL INTO A SHORT SYLLABLE   14280000
*                                  ENTRY FROM TOCAST                    14300000
SCANA    BAL   LKR,TOCODE1         AND STUFF IT.                        14320000
*                                  REENTRY WITH INPUT POINTER UPDATED   14340000
SCANUP   LA    6,1(6)                                                   14360000
*                                  REENTRY WITHOUT UPDATE               14380000
SCAN     SR    2,2                                                      14400000
         IC    2,0(6)              PUT CURRENT CHARACTER IN R2          14420000
         CL    2,QZ8BIT            IF IT'S SMALL ENOUGH,                14440000
         BL    SCANA1              IT'S NOT AN ACTION CHARACTER.        14460000
         S     2,QZDAU             CLASSIFY CHARACTER AS ZERO IF IT'S   14480000
         BNL   SCANB1              ALPHABETIC,                          14500000
         SR    2,2                                                      14520000
SCANB1   BZ    SCANB2                                                   14540000
         S     2,QF9               AND AS 1 IF IT'S NUMERIC.            14560000
         BP    SCANB2                                                   14580000
         LA    2,1                                                      14600000
SCANB2   LA    2,0(2,2)            MAKE R2 A HALFWORD INDEX             14620000
         LH    2,SCANT(2)                                               14640000
         B     IDL(2)              BRANCH TO ACTION ROUTINE.            14660000
*                                                                       14680000
SCANT    DC    Y(IDL-IDL,NUML-IDL),(ZLENGTH-Z9)Y(CHERR-IDL)             14700000
PER      SCANT PERL                                                     14720000
OVB      SCANT OVBL                                                     14740000
BLANK    SCANT SCANUP                                                   14760000
QUOTE    SCANT QUOTL                                                    14780000
COLON    SCANT COLNL                                                    14800000
DEL      SCANT DELL                                                     14820000
CR       SCANT CRL                                                      14840000
EOB      SCANT EOBL                                                     14860000
PDEL     SCANT PDELL                                                    14880000
LENGTH   SCANT COPVL                                                    14900000
         ORG                                                            14920000
*                                                                       14940000
*              COLON SEEN.                                              14960000
COLNL    LA    2,ZFCOLON           COLON REPLACED IN CODESTRING BY A    14980000
         L     1,TOCPTR            REPRESENTABLE SYMBOL.                15000000
         AR    1,MR                                                     15020000
         S     1,QF3               ONLY IF THE PRECEDING SYLLABLES ARE  15040000
         TM    2(1),1              A LONG SYL                           15060000
         BO    SCANA1                                                   15080000
         CLI   0(1),1+2*ZEOS       AND AN END-OF-STATEMENT SYL,         15100000
         BNE   SCANA1                                                   15120000
         MVI   0(1),1+2*ZLEOS      TURN EOS INTO A LABELLED-EOS SYL     15140000
         B     SCANA1                                                   15160000
*                                                                       15180000
*              QUAD-PRIME SPOTTED.  ACTION IS VERY SIMILAR TO QUOTE.    15200000
QUADPL   LA    2,CEOS              START BUILDING THE CODESTRING        15220000
         BCT   6,QUADP1            COMPENSATE FOR LA AT QUOTL4          15240000
*                                                                       15260000
*              COMMENT SYMBOL SPOTTED.  TREAT LINE LIKE QUAD-PRIME      15280000
REML     LA    2,CREM              LINE STARTS WITH COMMENT SYMBOL,     15300000
         OI    QUADTOG,STREMBIT    NOT END-OF-STATEMENT                 15320000
QUADP1   BAL   LKR,TOCODE1                                              15340000
*                                                                       15360000
*              OPENING QUOTE SPOTTED                                    15380000
QUOTL    MVC   TOCSAV(4),TOCPTR    REMEMBER PRESENT CODE-POINTER        15400000
*                                  FOR LENGTH CALCULATION.              15420000
         MVI   INLTMP+1,0          CARRIER WILL BE AT LEFT MARGIN       15440000
QUOTL4   LA    6,1(6)              ADVANCE POINTER TO NEXT CHARACTER    15460000
         TM    QUADTOG,STQPBIT+STREMBIT  IS THIS QUOTE INPUT --         15480000
         BZ    QUOTL1                                                   15500000
QUOTL8   EQU   *                                                   3563 15520000
         CLI   0(6),ZEOB           QUAD-PRIME OR COMMENT.  EOB OR CR    15540000
         BNE   QUOTL7                                              3563 15560000
         LA    LKR,QUOTL8          SET RETURN FROM EOBSB3          3563 15580000
         TM    COPTOG,COPIBIT      IS THIS A COPY SINK?            3563 15600000
         BO    QUOTL5              YES.  GO GET CONTINUATION       3563 15620000
         B     QUOTL3              NO.  END THIS LINE.             3563 15640000
QUOTL7   EQU   *                                                   3563 15660000
         CLI   0(6),ZCR                                                 15680000
         BNE   QUOTL2                                                   15700000
QUOTL3   L     2,TOCPTR            END OF QUOTED STRING.                15720000
*                                  DIFFERENCE OF OLD AND NEW CODE-      15740000
         S     2,TOCSAV            POINTERS IS THE LENGTH OF THE STRING 15760000
         BAL   LKR,TOCODE2         BUILD LENGTH SYLLABLE OF CONSTANT    15780000
         LA    2,CCCONST           THEN SEND CONSTANT SYLLABLE          15800000
         BAL   LKR,TOCODE1                                              15820000
         TM    QUADTOG,STQPBIT+STREMBIT  IN QUAD-PRIME OR COMMENT MODE, 15840000
         BNZ   CRL                 QUIT NOW.                            15860000
*                                  FOR QUOTED STRING,                   15880000
         B     SCAN                RESUME SCANNING AFTER ENDING QUOTE.  15900000
QUOTL6   LA    LKR,QUOTL1          SET RETURN FROM EOBSB3          3563 15920000
QUOTL5   TM    *+1,1               THIS IS A LOW, CHEAP TRICK TO        15940000
         B     EOBSB3              GET INTO EOBSUB FROM BACK WAY.  3563 15960000
QUOTL1   CLI   0(6),ZEOB           HAVE WE REACHED END-OF-LINE --       15980000
         BE    QUOTL6              YES.  ASK FOR MORE              3563 16000000
         CLI   0(6),ZQUOTE         CHECK FOR EMBEDDED QUOTE             16020000
         BNE   QUOTL2                                                   16040000
         BAL   LKR,EOBSUBI         QUOTE.  CHECK FOR FOLLOWING QUOTE.   16060000
         CLI   0(6),ZQUOTE                                              16080000
         BNE   QUOTL3              QUOTE NOT DOUBLED -- END OF STRING.  16100000
QUOTL2   IC    2,0(6)              PASS THIS CHARACTER ALONG TO         16120000
         BAL   LKR,TOCODE1         THE CODESTRING.                      16140000
         B     QUOTL4                                                   16160000
         EJECT                                                          16180000
*                                                                       16200000
*        COPY-VARIABLE SIGNAL (CHARACTER = ZLENGTH) SCANNED.            16220000
*        FORMAT OF MESSAGE IS ..                                        16240000
*        IDENTIFIER                (ALREADY SCANNED)                    16260000
*        ZLENGTH                   1-BYTE SIGNAL, COPY MODE ONLY        16280000
*        BYTE COUNT OF M-ENTRY     4 BYTES                              16300000
*          (OR SYMBOL TABLE ENTRY IF A KEYWORD)                         16320000
*                                                                       16340000
*        SUCCEEDING INPUTS ARE LINKED BUFFERS OF RAW                    16360000
*        M-ENTRY, STARTING WITH FIRST BYTE PAST MCOUNT.                 16380000
*                                                                       16400000
*        RELIES ON R3 SAVED FROM  SRCHID                                16420000
*                                                                       16440000
COPVL    BAL   LKR,TUSAG           DETERMINE GLOBAL MEANING             16460000
         LA    LKR,DELCHV                                               16480000
         MVC   DTEMP(4),1(6)       GET NEW COUNT FROM INPUT             16500000
         BAL   8,DELCHA            AND SEE IF WE REALLY WANT TO COPY    16520000
         OI    COPTOG,COPVBIT      NOTE ACCEPTABILITY OF OBJECT         16540000
         BAL   8,RELPNS            POSSIBLY RELOCATE PRINTNAME DOWNWARD 16560000
         L     1,DTEMP                                                  16580000
         LTR   1,1                 AND GET SPACE FOR NEW M-ENTRY.       16600000
         BM    COPOP               NO M-ENTRY IF IT'S A KEYWORD         16620000
         LA    0,40(1)             ADD 40 BYTES SLOP AND           5995 16640000
         BAL   LKR,FREECH1         CHECK FOR WS FULL.              5995 16660000
         L     1,MX                BUILD M-ENTRY FOR VARIABLE      5995 16700000
         L     0,DTEMP                                             5995 16720000
         ST    0,MCOUNT(1)         STORE M-ENTRY LENGTH            5995 16740000
         AR    0,1                                                 5995 16760000
         ST    0,MX                UPDATE MX                       5995 16780000
         ST    3,MHEAD(1)          POINT M-ENTRY AT SYMBOL TABLE        16800000
*                                  (OR STACK)                           16820000
         LR    5,1                                                      16840000
         O     1,UNVAR             AND SYMBOL TABLE (INCLUDING CLASS =  16860000
         ST    1,M(3)              VARB) AT M-ENTRY.                    16880000
*              REENTRY TO IGNORE VARIABLE OR KEYWORD                    16900000
DELCHV   L     4,DTEMP             PREPARE TO IGNORE, OR FILL M-ENTRY.  16920000
         S     4,QAMOVH            COUNT MINUS OVERHEAD IS AMT OF INPUT 16940000
         BNP   BEGST2              CASE OF IGNORED KEYWORD              16960000
COPVL1   TYI                                                            16980000
         AR    5,MR                ABSOLUTE SINK ADDRESS                17000000
         L     3,MPTBASE                                                17020000
         L     3,PTIBUF-PERTERM(3) POINT TO FIRST BUFFER                17040000
         USING PERBUF,3                                                 17060000
COPVL3   LH    2,PBCCW+6           BYTES IN THIS BUFFER                 17080000
         TM    COPTOG,COPVBIT      NO MOTION IF IGNORANCE IN PROGRESS   17100000
         BZ    COPVL4                                                   17120000
         EX    2,COPVLMV           AN EXTRA BYTE IS MOVED * * * * *     17140000
         AR    5,2                 DEST IS DEST PLUS BUFFERLENGTH       17160000
COPVL4   SR    4,2                 REMAINING BYTES TO MOVE              17180000
         TM    PBFLAG,LINEZ        TEST TO SEE IF PBTIC IS VALID        17200000
         L     3,PBTIC             POINT TO PROBABLE NEXT BUFFER        17220000
         BZ    COPVL3              NEXT BUFFER EXISTS                   17240000
         SR    5,MR                MAKE IT M-RELATIVE                   17260000
         LTR   4,4                                                      17280000
         BP    COPVL1              ALL INPUT READ (SHOULD NEVER BE -)-- 17300000
         NI    COPTOG,255-COPVBIT  RESET FLAG WITH LOCAL SIGNIFICANCE   17320000
         B     BEGST2                                                   17340000
COPVLMV  MVC   MTYPE-M(0,5),PBSTAR                                      17360000
         DROP  3                                                        17380000
COPOP    ST    1,M(3)              STORE KEYWORD SYMBOL TABLE ENTRY     17400000
         B     BEGST2              IN SYMBOL TABLE                      17420000
*                                  THIS IS AN IDENTIFIER DEFINED AS     17440000
*                                  A PRIMITIVE OPERATOR OR OTHER SYMBOL 17460000
         EJECT                                                          17480000
*                                                                       17500000
*              CONSTANT BEGINNER SPOTTED                                17520000
OVBL     EQU   *                                                        17540000
PERL     EQU   *                                                        17560000
NUML     MVC   TOCSAV(4),TOCPTR    SAVE INITIAL VALUE OF CODESTRING PTR 17580000
         SR    0,0                                                      17600000
         ST    0,CCNT              SET CONSTANT COUNT TO 0              17620000
         ST    0,CTYP                                                   17640000
         MVI   ICVFG,0             RESET ALL INPUT CONVERT FLAGS        17660000
NUML14   BAL   LKR,ICV             CONVERT CONSTANT                     17680000
         TM    ICVFG,QUBIT    IF BAD SYNTAX WAS FOUND IN           P054 17700000
         BNZ   NUMCLS         ICV THEN CLOSE THIS CONSTANT         P054 17720000
         AGO   .NUML1                                              P054 17740000
.NUML1   ANOP                                                      P054 17760000
NUML15   LA    3,2                 DETERMINE IMPLIED TYPE OF THIS CONST 17780000
         TM    ICVFG,FLBIT         IS IT FLOATING --                    17800000
         BO    NUML4               YES.                                 17820000
         L     3,DTEMP             IT'S INTEGER.                        17840000
         N     3,QFM2              IF IT'S 1 OR 0,                      17860000
         BZ    NUML4               CALL IT BOOLEAN.                     17880000
         LA    3,1                                                      17900000
*                                                                       17920000
*              NOW R3 = PRESENT CONSTANT TYPE - 1                       17940000
*              CATENATE CURRENT CONSTANT TO PREVIOUS CONSTANTS IN VEC-  17960000
*              TOR.  TYPES MAY DIFFER, REQUIRING CONVERSION OF PREVIOUS 17980000
*              CONSTANTS.                                               18000000
NUML4    L     4,TOCPTR                                                 18020000
         L     2,CCNT                                                   18040000
         LR    0,3                                                      18060000
         A     0,CTYP              NO WORRIES IF TYPES ARE THE SAME     18080000
         C     3,CTYP                                                   18100000
         BNH   NUML5               (LOW ONLY IF R3 = 0 AND CTYPE = 1)   18120000
         ST    3,CTYP                                                   18140000
         LTR   1,2                 OR IF THIS IS THE FIRST CONSTANT.    18160000
         BZ    NUML5                                                    18180000
*              NEW ELEMENT OF VECTOR HAS HIGHER TYPE THAN OLD ELEMENTS. 18200000
*              EXPAND OLD ELEMENTS TO HIGHER TYPE BEFORE CATENATING     18220000
*              NEW ELEMENT.                                             18240000
*                                                                       18260000
*              FIRST DETERMINE ADDITIONAL STORAGE NEEDED.               18280000
*              R0 = TYPE-CONVERSION CODE.                               18300000
*                  = 0 - 1  PLUS  1 - 2                                 18320000
*                  = 1 BOOLEAN TO INTEGER                               18340000
*                  = 2 BOOLEAN TO FLOATING                              18360000
*                  = 3 INTEGER TO FLOATING                              18380000
*                                                                       18400000
         ST    0,FTEMP1            SAVE TYPE COMBINATION FOR LATER      18420000
         SLL   1,2                                                      18440000
         BCT   0,NUML6             CONVERSION.                          18460000
NUML9    LA    2,7(2)              ROUND BITS UP TO EVEN BYTE           18480000
         SRL   2,3                 MAKE BYTE INDEX                      18500000
         SR    1,2                 AND SUBTRACT CURRENT SIZE FROM SIZE  18520000
*                                  NEEDED FOR INTEGERS                  18540000
NUML6    BCT   0,NUML8                                                  18560000
         ALR   1,1                 BOOLEAN TO FLOATING CONVERSION.      18580000
         B     NUML9               ALMOST SAME AS INTEGER               18600000
*              NOW R1 = NUMBER OF BYTES NEEDED FOR HIGHER TYPE.         18620000
*                  R4 = TOCPTR                                          18640000
NUML8    AR    4,1                 INTEGER TO FLOATING CONVERSION.      18660000
         ST    4,TOCPTR            GIVE CODESTRING POINTER NEW VALUE.   18680000
         BAL   LKR,FREECH          MAKE SURE WE HAVE THE SPACE          18700000
         CLI   FTEMP1+3,3                                               18720000
         BE    NUML19                                                   18740000
         ST    4,FTEMP2            THE BOOLEAN CONVERSIONS.             18760000
         LM    2,4,CCNT            SET UP CALL OF FETCH                 18780000
         IC    3,TCCOD-1(3)        GET TYPE-CONVERSION CODE             18800000
NUML18   BCTR  2,0                 AND 0-ORIGIN INDEX                   18820000
         ICALL FETCH                                                    18840000
         ST    0,NTEMP                                                  18860000
         CLI   FTEMP1+3,1          IS RESULT IN R0 OR F0 --             18880000
         BE    NUML17                                                   18900000
         STD   0,NTEMP             F0.                                  18920000
NUML17   L     5,FTEMP1                                                 18940000
         IC    5,NUMTL-1(5)        FIND LENGTH OF CONVERTED CONSTANT    18960000
         LCR   1,5                                                      18980000
         A     1,FTEMP2            DROP SINK ADDRESS BY CONSTANT LENGTH 19000000
         ST    1,FTEMP2                                                 19020000
         AR    1,MR                ABSOLUTIZE IT                        19040000
         BCTR  5,0                                                      19060000
         EX    5,NUM18M            MOVE TARGET TO NEW CODESTRING LOCN.  19080000
         LTR   2,2                 HAVE ALL CONSTANTS BEEN MOVED --     19100000
         BP    NUML18              NO.  DO THE NEXT.                    19120000
         B     NUML15                                                   19140000
*                                                                       19160000
*              MOVE AND CONVERT INTEGER TO FLOATING                     19180000
NUML19   L     2,QFM4              DECREMENT FOR BXH                    19200000
         LA    3,M(2)                                                   19220000
         A     3,TOCSAV                                                 19240000
         LA    5,0(3,1)                                                 19260000
         AR    4,MR                                                     19280000
*              NOW R1 = CCNT * 4                                        19300000
*                  R2 = -4                                              19320000
*                  R3 = TOCSAV - 4 (ABSOLUTE)                           19340000
*                  R5 = TOCSAV - 4 + CCNT * 4 (ABSOLUTE)                19360000
*                     = INDEX OF LAST CONSTANT                          19380000
NUML20   S     4,QF8               BUMP SINK TO NEW SLOT                19400000
         MVC   DMASK+4(4),0(5)     MAKE INTEGER INTO                    19420000
         XI    DMASK+4,X'80'            (EXCESS 2*31)                   19440000
         LD    0,DMASK             NORMALIZED FLOATING.                 19460000
         SD    0,DTOPS             REMOVE EXCESS AND NORMALIZE          19480000
         STD   0,NTEMP                                                  19500000
         MVC   0(8,4),NTEMP        MOVE FLOATED CONSTANT INTO SINK      19520000
         BXH   5,2,NUML20                                               19540000
         B     NUML15              RESTORE REGISTERS                    19560000
*                                                                       19580000
*              NOW R2 = CONSTANT COUNT                                  19600000
*                  R3 = CURRENT CONSTANT TYPE                           19620000
*                  R4 = TOCPTR                                          19640000
NUML5    LA    2,1(2)              BUMP CONSTANT COUNT                  19660000
         ST    2,CCNT                                                   19680000
         L     3,CTYP              ALREADY LOADED EXCEPT FOR THE CASE   19700000
*                                  2,1,   IN WHICH CTYP = 1, R3 = 0     19720000
         CLI   CCNT+2,X'80'        DISALLOW CONSTANT VECTORS OF MORE    19740000
         BNL   TROUBLE             THAN 32,767 ELEMENTS                 19760000
         IC    3,BYPERT(3)         PREPARE TO MOVE CONSTANT INTO THE    19780000
         LTR   3,3                 CODESTRING.                          19800000
         BNE   NUML11              LOOK AT TYPE.                        19820000
         BCTR  2,0                 BOOLEAN CONSTANT.  GET 0-ORIGIN      19840000
         SRDL  2,3                 BIT INDEX.                           19860000
         A     2,TOCSAV                                                 19880000
         IC    0,M(2)              PICK UP PREVIOUS BITS OF VECTOR      19900000
         SRL   3,29                                                     19920000
         LCR   3,3                 COMPUTE SHIFT QUANTITY               19940000
         SRL   0,7(3)                                                   19960000
         N     0,QFM2                                                   19980000
         O     0,DTEMP             CATENATE NEW BIT TO RH END OF BITS   20000000
         SLL   0,7(3)                                                   20020000
         STC   0,M(2)              AND PUT BITS BACK IN CODESTRING      20040000
         LA    2,1(2)              TOCPTR IS 1 PAST THIS BYTE           20060000
         B     NUML12                                                   20080000
NUML11   LA    2,1(3,4)            FIXED AND FLOATING MOVES.            20100000
         AR    4,MR                JUST MOVE THE CONSTANT AT DTEMP.     20120000
         EX    3,NUMVC                                                  20140000
NUML12   ST    2,TOCPTR            STORE UPDATED TOCPTR.                20160000
         BAL   LKR,FREECH     CHECK FOR 20 BYTES OF SLOP           P054 20180000
         LR    5,6            SKIP OVER BLANKS (OR 1050 EOB)       P054 20200000
         BAL   LKR,SKBL       BUT                                  P054 20220000
         CR    5,6            CLOSE THIS CONSTANT IF NO            P054 20240000
         BE    NUMCLS         BLANKS OR EOB                        P054 20260000
         CLI   0(6),Z0        IF NONBLANK IS                       P054 20280000
         BL    NUMCLS         A CONSTANT BEGINNER                  P054 20300000
         CLI   0(6),ZOVB      THEN WE ARE BUILDING                 P054 20320000
         BNH   NUML14         A VECTOR                             P054 20340000
NUMCLS   L     1,TOCSAV       RESET CODE STRING POINTER            P054 20360000
         L     2,CCNT         FETCH CONSTANT COUNT                 P054 20380000
         LTR   2,2            AND IF WE HAVE                       P054 20400000
         BZ    NUMC1          SOMETHING THEN                       P054 20420000
         BAL   LKR,TOCODE2    STUFF COUNT IN CODE STRING           P054 20440000
         L     2,CTYP         FETCH APPROPRIATE                    P054 20460000
         IC    2,CONSYL(2)    CONSTANT SYLLABLE AND                P054 20480000
         BAL   LKR,TOCODE1    STUFF IT IN CODE STRING              P054 20500000
NUMC1    LA    2,ZFPER        CHECK FOR CAUSE OF ILLEGAL           P054 20520000
         CLI   0(6),ZPER      CONSTANT DETECTED BY ICV             P054 20540000
         BE    SCANA1         IF ITS A PERIOD OR OVERBAR           P054 20560000
         LA    2,ZFOVB        SEND IT TO CODE STRING VIA           P054 20580000
         CLI   0(6),ZOVB      SCANA1 SO THAT SCAN WILL             P054 20600000
         BE    SCANA1         NOT CALL NUML AGAIN WITH  THE        P054 20620000
         B     SCAN           SAME CHARACTER                       P054 20640000
         AGO   .NUMLE                                              P054 20660000
.NUMLE   ANOP                                                      P054 20680000
NUM18M   MVC   0(0,1),NTEMP        MOVE IN CONSTANT-EXPANSION           20700000
NUMVC    MVC   0(0,4),DTEMP        FOR MOVING INT/FLT CONSTANTS TO CDST 20720000
TCCOD    DC    AL1(CVBTOI,CVBTOF)  TYPE-CONVERSION CODES                20740000
CONSYL   DC    AL1(CBCONST,CICONST,CFCONST)                             20760000
NUMTL    DC    FL1'4,8'                                                 20780000
BYPERT   DC    FL1'0,3,7'          MOVE LENGTHS                         20800000
         EJECT                                                          20820000
*                                                                       20840000
*              BUILD AN IDENTIFIER                                      20860000
IDL      EQU   *                                                        20880000
         LA    2,1+2*ZSDELTA       MAKE A QUICK, GLITCH CHECK           20900000
         CLC   0(2,6),QZSD         FOR PROGRAMMED STOP (S DELTA)        20920000
         BE    IDL2                                                     20940000
         LA    2,1+2*ZTDELTA       OR TRACE (T DELTA)                   20960000
         CLC   0(2,6),QZTD         PRECEDING IDENTIFIER.                20980000
         BNE   IDL3                                                     21000000
IDL2     LA    6,1(6)              IF PRESENT, LOP IT OFF THE IDENT     21020000
         B     SCANA               AND SEND A 'STOP' OR 'TRACE' TO CS   21040000
IDL3     BAL   LKR,SRCHID          CATENATE CHARACTERS                  21060000
         ST    2,LASTID            SYMBOL MAY BE WANTED LATER.          21080000
         BAL   LKR,TOCODE2         STUFF THE LONG SYLLABLE              21100000
         B     SCAN                                                     21120000
*                                                                       21140000
*        BUILD AN IDENTIFIER AND SEARCH FOR IT IN THE SYMBOL TABLE.     21160000
*        IF IT'S NOT THERE, INSERT IT AND MAKE IT AN UNDEFINED VARB.    21180000
*        ON ENTRY, R6 = ABSOLUTE ADDRESS OF NEXT CHARACTER              21200000
*        ON EXIT,  R6 = UPDATED CHARACTER ADDRESS                       21220000
*                  R5 = CHARACTER COUNT                                 21240000
*                  R2 = M-RELATIVE ADDRESS OF SYMBOL ENTRY              21260000
SRCHID   ST    LKR,SRCHRET         SAVE RETURN LINK                     21280000
         BAL   LKR,BLDID           BUILD THE IDENTIFIER                 21300000
         ST    6,SRCHRET+4         SAVE DELIMITER ADDRESS               21320000
         LR    3,5                 GET CHARACTER COUNT OFFSET BY 1 FOR  21340000
         BCTR  3,0                 CLC                                  21360000
         LM    0,1,NEWID           SCRAMBLE FIRST 8 CHARS OF NEW NAME   21380000
         SLL   1,4                                                      21400000
         ALR   1,0                                                      21420000
         ALR   1,5                                                      21440000
         M     0,FOLDER                                                 21460000
         ALR   1,0                                                      21480000
         L     8,QR13STK           DETERMINE SYMBOL TABLE SIZE          21500000
         L     4,QSYMBOT                                                21520000
         SR    8,4                                                      21540000
         LR    LKR,8               TOTAL LENGTH                         21560000
         SRL   8,3                 NUMBER OF SYMBOLS                    21580000
         AR    4,MR                ABS ADDRESS, BOTTOM OF TABLE         21600000
         SR    0,0                 GET TABLE SIZE RESIDUE               21620000
         SRL   1,3                 OF HASHED SYMBOL FOR FIRST LOOKUP    21640000
         DR    0,8                                                      21660000
         LR    1,0                                                      21680000
         SLL   1,3                 SYMBOLS ARE DOUBLEWORDS              21700000
SRCHC    CLR   1,LKR               BRING R1 BACK INTO BOUNDS OF         21720000
         BL    SRCHJ               SYMBOL TABLE                         21740000
         SR    1,LKR                                                    21760000
SRCHJ    LA    2,0(1,4)            GET ABS ADDRESS OF THIS BST ENTRY    21780000
SRCHCL   CLI   4(2),0              IS THIS SPACE OCCUPIED --            21800000
         BE    SRCHB               NO.  PUT OUR SYMBOL HERE.            21820000
         EX    5,SRCHCL            DO CHARACTER COUNTS MATCH --         21840000
         BNE   SRCHG                                                    21860000
         CLI   4(2),4              YES.  FIND PRINT NAME OF SYMBOL.     21880000
         BL    SRCHD                                                    21900000
         L     2,4(2)              PNAME OF 4 OR MORE CHARACTERS HAS    21920000
         LA    2,MPNAME-4(2)       CHARACTERS STORED AS AN M-ENTRY.     21940000
SRCHD    EX    3,SRCHCC            COMPARE PNAME AGAINST NEW ID.        21980000
         LA    2,0(1,4)            (RESTORE BST POINTER)                22000000
         BE    SRCHR               HOORAY -- THEY'RE THE SAME.          22020000
SRCHG    LA    1,168(1)            168 IS A SEMI-MAGIC CONSTANT         22040000
QH168    EQU   SRCHG+2                                                  22060000
*                                  DESIGNED TO AVOID INSPECTION OF A    22080000
*                                  SYMBOL WHICH IS A HAMMING DISTANCE   22100000
*                                  OF ONE FROM NEW ID.  IT ALSO IS      22120000
*                                  RELATIVELY PRIME TO BST LENGTH SO    22140000
*                                  WE DON'T MISS ANY POSITIONS.         22160000
         BCT   8,SRCHC             PROTECTION AGAINST FULL SYMBOL TABLE 22180000
SRCHK    TM    COPTOG,COPOBIT      CHECK FOR UNUSUAL CASE OF FULL S.T.  22200000
*                                  IN COPY SOURCE.  TREAT THIS AS       22220000
         BO    COPERR              'OBJECT NOT FOUND'.                  22240000
         BAL   1,PPERR                                                  22260000
         DC    AL1(17,ZS,ZY,ZM,ZB,ZO,ZL,ZBLANK,ZT,ZA,ZB,ZL,ZE,ZBLANK,ZF.22280000
               ,ZU,ZL,ZL)                                               22300000
SRCHCC   CLC   5(0,2),0(7)         THE EXECUTED CLC                     22320000
*                                                                       22340000
*              INSERT NEW SYMBOL IN SYMBOL TABLE.                       22360000
*        NOW,  R1 = BST-RELATIVE ADDRESS OF SYMBOL TABLE ENTRY          22380000
*              R2 = ABS ADDRESS OF SYMBOL TABLE ENTRY                   22400000
*              R3 = CHARACTER COUNT - 1                                 22420000
*              R5 = CHARACTER COUNT                                     22440000
*              R6 = ABS ADDRESS OF NEXT INPUT CHARACTER                 22460000
*              R7 = ABS ADDRESS OF FIRST CHAR OF ID                     22480000
*                                                                       22500000
SRCHB    STC   5,4(2)              SET CHARACTER COUNT IN PNAME WORD    22520000
         MVC   0(4,2),UNVAR        MAKE CLASS VARB, VALUE UNDEFINED     22540000
         LR    1,2                                                      22560000
         CLI   4(2),4              IS IT THREE OR LESS --               22580000
         BL    SRCHE               YES.  INSERT PRINT NAME DIRECTLY.    22600000
         LA    4,MPNAME-M+4(5)     NO.  RESERVE FULLWORDS IN M          22620000
         N     4,QFM4              FOR PRINT NAME.                      22640000
         LA    0,60(4)             INCLUDE A SAFETY MARGIN, AND         22660000
         L     6,SRCHRET+4                 (FOR ERROR DISPLAY)          22680000
         BAL   LKR,FREECH1         CHECK FREE SPACE SITUATION.          22700000
         LCR   1,4                 SAVE LENGTH MOMENTARILY              22720000
         A     1,SVI               PNAME ENTRY GOES ON THE STACK FOR    22740000
         ST    1,SVI               THE MOMENT BECAUSE TOP OF M IS       22760000
*                                  OCCUPIED WITH AN OPEN CODESTRING.    22780000
         LA    1,4(1)              BUMP R1 TO ADDRESS 1ST WORD OF ENTRY 22800000
*              NOW R1 = PNAME ADDRESS                                   22820000
*                  R2 = ABSOLUTE BST ADDRESS                            22840000
         ST    1,4(2)              POINT PNAME WORD OF BST ENTRY AT     22860000
*                                  PNAME M-ENTRY                        22880000
         STC   5,4(2)              RE-STORE CHARACTER COUNT             22900000
         STC   5,MPNAME(1)                                              22920000
         ST    4,MCOUNT(1)         PUT BYTE COUNT IN COUNT WORD         22940000
         LA    4,4(2)              BUMP R4 TO ADDRESS PNAME WORD OF     22960000
         SR    4,MR                BST ENTRY                            22980000
         ST    4,MHEAD(1)          POINT M-ENTRY AT BST PNAME WORD      23020000
         LA    1,MPNAME-4(1)       FIND ABS DATA ADDRESS IN M-ENTRY     23040000
SRCHE    EX    3,SRCHMV            AND MOVE PRINT NAME INTO IT.         23060000
SRCHR    LR    3,2                 CALLER MAY WANT SYMBOL TABLE ADDR    23080000
         SR    3,MR                M-RELATIVE                           23100000
         SR    2,LR                RELATIVIZE R2                        23120000
*                                  WE ASSUME THAT LR = MR + R13STK      23140000
         SRA   2,2                                                      23160000
         L     LKR,SRCHRET                                              23180000
         L     6,SRCHRET+4         RELOAD INPUT POINTER                 23200000
         BR    LKR                                                      23220000
SRCHMV   MVC   5(0,1),0(7)         EXECUTED MOVE FOR PRINT NAMES        23240000
*                                                                       23260000
*        BUILD AN IDENTIFIER.                                           23280000
*        ON ENTRY, R6 = ABSOLUTE INPUT CHARACTER POINTER                23300000
*        ON EXIT,  R6 IS UPDATED TO 1 PAST LAST CHARACTER OF IDENTIFIER 23320000
*                  R5 IS CHARACTER COUNT                                23340000
*                  R7 IS POINTER TO FIRST CHARACTER OF ID               23360000
BLDID    LR    7,6                                                      23380000
         LA    5,NEWID-1                                                23400000
         LA    2,1                                                      23420000
         LA    3,NEWID+7           SET UP BXH LOOP                      23440000
NEWIDZ   XC    NEWID(8),NEWID                                           23460000
BLDID2   CLI   0(6),ZA             SCAN INPUT UNTIL NONALPHANUMERIC     23480000
         BL    BLDID4              CHARACTER IS FOUND.                  23500000
         CLI   0(6),Z9                                                  23520000
         BH    BLDID4                                                   23540000
         BXH   5,2,BLDID3          MOVE FIRST EIGHT CHARACTERS OF       23560000
         MVC   0(1,5),0(6)         IDENTIFIER INTO NEWID.               23580000
BLDID3   LA    6,1(6)              BUMP INPUT POINTER TO                23600000
         B     BLDID2              NEXT CHARACTER.                      23620000
BLDID4   LCR   5,7                 DELIMITER SPOTTED.                   23640000
         AR    5,6                 FIND LENGTH OF IDENTIFIER            23660000
         C     5,QF77              IF IT'S MORE THAN 77 CHARACTERS,     23680000
         BCR   13,LKR                                                   23700000
         LA    5,77                IGNORE THOSE PAST 77TH AND CALL ITS  23720000
         BR    LKR                 LENGTH 77.                           23740000
         EJECT                                                          23760000
*                                                                       23780000
*              CLOSING DEL SCANNED.                                     23800000
CDELL    BAL   LKR,SKBLI           ENSURE THAT DEL IS LAST NONBLANK     23820000
         CLI   0(6),ZCR                                                 23840000
         BNE   FNERR               ON LINE                              23860000
         OI    FDTOG,FDCLBIT       DEFINITELY CLOSING THIS DEFINITION   23880000
*                                                                       23900000
*              CARRIAGE RETURN SCANNED.  END OF STATEMENT.              23920000
CRL      LM    1,2,TOCORG          (TOCORG, TOCPTR)                     23940000
         LA    0,3(2)              POLISH OFF THE CODESTRING.           23960000
         N     0,QFM4              ROUND IT UP TO A WORD BOUNDARY       23980000
         LR    5,0                                                      24000000
         SR    0,1                 PUT BYTE COUNT IN COUNT WORD.        24020000
         ST    0,MCOUNT(1)                                              24040000
         LA    0,MCSORG-M(1)       NOW GET TRUE BYTE COUNT              24060000
         SR    2,0                 (I.E, BYTE COUNT OF SYLLABLES)       24080000
         STH   2,MCSCNT(1)         STORE BYTE COUNT OF SYLLABLES        24100000
         CLI   FDTOG,0             ARE WE DEFINING A FUNCTION --        24120000
         BNE   CRL1                YES.  BYPASS EMPTY-LINE CHECK.       24140000
         C     2,P10               IF SYL CNT IS 1, CODESTRING CONSISTS 24160000
         BE    BEGST2              SOLELY OF AN EOS AND THE INPUT LINE  24180000
*                                  SOLELY OF A CR.  ASK FOR MORE INPUT. 24200000
         TM    QUADTOG,STREMBIT    DITTO FOR COMMENT LINE IN IMMEDIATE- 24220000
         BO    BEGST2B             EXECUTION.                           24240000
         TM    COPTOG,COPIBIT      ARE WE A COPY SINK              3575 24260000
         BO    TYOSDCOP              YES.  MUST BE END-COPY MSG    3575 24280000
CRL1     L     3,PARREL            SET CODESTRING INFORMATION           24300000
         LA    4,STCODE(3)         INTO THE STACK AND VICE VERSA.       24320000
         ST    4,MHEAD(1)          POINT CODESTRING AT STACK            24360000
         O     1,QCODCLS                                                24380000
         ST    1,STCODE(3,MR)      AND STACK AT CODESTRING.             24400000
         STH   2,STCPTR(3,MR)      PUT INITIAL SYLLABLE BYTE COUNT IN   24420000
         ST    5,MX                                                     24440000
         CLI   FDTOG,0             IF WE'RE DEFINING A FUNCTION,        24460000
         BNE   CRL2                THERE IS MUCH MORE TO BE DONE.       24480000
         ON    FP                  REVERT TYPEIN-SET CONDITIONS         24500000
         BAL   8,RELPNS            AND DO A GIANT GARBAGE COLLECTION.   24520000
         BAL   LKR,TYOSD           POSSIBLY PRINT 'STACK DAMAGED'       24540000
         ON    ATTN,=V(BGATTNX)    ENABLE FORCED ATTENTION              24560000
*                                  IN CASE OF TIME LIMIT OR DOUBLE ATTN 24580000
         ICALL SYNTXX              OFF TO THE INTERPRETER --            24600000
         B     TYPTOP              AND BACK TO THE TYPEWRITER.          24620000
CRL2     EQU   *                   END OF STATEMENT IN FUNCTION DEFINT. 24640000
         ST    2,SCSCNT                                                 24660000
         BAL   LKR,PRIFN           POSSIBLY DISPLAY, FIND OUR LINE NO.  24680000
         L     7,SCSCNT            RECALL BYTE COUNT                    24700000
         BCT   7,CRL5              FOR CURRENT LINE.  IS IT EMPTY --    24720000
CRLM     MVC   MX,TOCORG           YES.  RELEASE ITS STORAGE.           24740000
*              ***** WORKS ONLY BECAUSE WE KNOW CS IS LAST M-ENTRY **** 24760000
         TM    LFTOG,X'10'         DID SOURCE CONTAIN A LINE-DELETING   24780000
         BO    CRL5A               LINE-FEED --                         24800000
         NI    DPYTOG,255-DPYNMT   NO.  IGNORE THIS LINE COMPLETELY.    24820000
*                                  SET DPYTOG TO INHIBIT LINE-BUMPING   24840000
         TM    DPYTOG,DPYED        IS CHARACTER EDITING REQUESTED --    24860000
         BZ    CRL8A                                                    24880000
         CLI   OBUF,ZLBR           YES.  IGNORE REQUEST IF 1ST CHAR OF  24900000
*                                  LAST LINE WAS NOT A LEFT BRACKET --  24920000
*                                  I.E. IF DISPLAYED STATEMENT EXTENDED 24940000
         BNE   CRL8A               OVER MORE THAN ONE LINE.             24960000
         OI    INTOG,CEBIT         SET 'CHAR EDIT' FLAG FOR INLINE      24980000
         MVC   CETMP(2),LLLO       SAVE LENGTH OF DISPLAYED STATEMENT   25000000
         B     CRL8A                                                    25020000
*              NEW STATEMENT EXISTS.                                    25040000
*              REPLACE OLD STATEMENT (IF ANY) BY NEW STATEMENT (IF ANY) 25060000
CRL5     LM    1,2,MX ,SVI         CALCULATE REMAINING FREE SPACE IN M  25080000
         LA    0,80(1)                                              A01 25100000
         SR    0,2                 REJECT THE NEW CODESTRING UNLESS     25120000
         BM    CRL5A               ENOUGH FREE STORAGE REMAINS TO AT    25140000
         EX    0,CRLM              LEAST DELETE OTHER LINE IN THIS FN.  25160000
         B     TROUBLE             PRINT 'WS FULL'                      25180000
CRL5A    L     1,FLINENO           TAKE SPECIAL ACTION IF THIS IS       25200000
         BXLE  1,1,FLOSC           FUNCTION HEADER ( LINE 0 )           25220000
*              THIS TEST MUST PRECEDE THE   BAL 8,RELPNS  AT CRL7       25240000
*              SINCE FLOSC MAY EXPAND THE CODESTRING FOR LINE 0         25260000
CRL5B    L     4,PRIFT             PREPARE TO DELETE OLD LINE           25280000
         LTR   2,4                 IS THERE AN OLD LINE WITH THIS NO.-- 25300000
         BZ    CRL7                NO.  MAKE NEW SPACE FOR THIS CODESTR 25320000
         L     1,PARREL            ING AND CARRY OVER ANY TRACE, STOP   25340000
         IC    0,MHEAD(4)          SETTINGS.                            25360000
         STC   0,STCODE(1,MR)                                           25380000
         BAL   1,MKCSGI            MARK OLD LINE GARBAGE                25400000
         B     CRL6                                                     25420000
*                                                                       25440000
*        THIS LINE NUMBER IS NEW FRACTIONAL OR OUT-OF-RANGE INTEGRAL.   25460000
*        CREATE A 3-WORD ENTRY FOR CODESTRING POINTER (AND LINE NO)     25480000
*        ON THE STACK.                                                  25500000
CRL7     BXLE  1,7,CRL8A                                            A01 25520000
         BAL   8,RELPNS            MOVE LONG PRINTNAMES DOWN        A01 25540000
*                                  WE NEED THE SPACE FOR FRLN ENTRY.    25560000
         L     3,SVIT              RESERVE THREE WORDS AT SVIT          25580000
         S     3,QF12                                                   25600000
         ST    3,SVIT                                                   25620000
         ST    3,SVI                                                    25640000
         LA    2,4(3)              R2 IS POINTER TO FIRST WORD          25660000
         L     4,LINTF                                                  25680000
         AR    4,MR                GET ABSOLUTE ADDRESS OF ENTRY FOR    25700000
         LA    3,M(2)              NEXT LOWER-NO LINE, AND NEW SLOT     25720000
         USING FLENT,3                                                  25740000
         MVC   FLENTLNK,FLENTLNK-FLENT(4)  MOVE LOWER-NO LINK INTO      25760000
         MVC   FLENTNO,FLINENO     NEW SPACE, NEW LINE INTO NEW SPACE,  25780000
         ST    2,FLENTLNK-FLENT(4) AND ADDR OF NEW LINE ENTRY INTO OLD  25800000
*                                  SPACE.                               25820000
         DROP  3                                                        25840000
*              REENTRY FOR IN-RANGE INTEGRAL LINE NUMBER                25860000
*              NOW R2 = ADDRESS OF CODESTRING POINTER                   25880000
*                  R5 = ADDRESS OF CODESTRING + CODESTRING CLASS        25900000
*                  R7 = BYTE COUNT OF CODESTRING SYLLABLES, - 1         25920000
CRL6     L     3,PARREL            NEW CODESTRING POINTER WAS STORED    25940000
         L     5,STCODE(3,MR)      IN STACK TEMPORARILY.                25960000
         SR    0,0                 CLEAR STACK LOCATION FOR             25980000
         ST    0,STCODE(3,MR)      CLEANLINESS                          26000000
         ST    7,M+FLENTCSA-FLENTCSA(2)  STORE ZERO IN DIRECTORY, OR,   26020000
         BXLE  7,7,CRL8            IF CODESTRING IS NOT EMPTY,          26040000
*                                  STORE POINTER TO IT IN FN DIRECTORY  26060000
*                                  (OR FRACTIONAL-LINE LIST.)           26080000
         ST    5,M+FLENTCSA-FLENTCSA(2)                                 26100000
         ST    2,MHEAD(5)          POINT CODESTRING BACK AT CODESTRING  26160000
*                                  POINTER                              26180000
CRL8     BAL   8,RELPNS            MOVE LONG PRINTNAMES DOWN TO MX      26200000
*                                  DOING THIS EARLIER WOULD MAKE PRIFT  26220000
*                                  UNRELIABLE.                          26240000
CRL8A    TM    FDTOG,FDCLBIT       ARE WE CLOSING THIS DEFINITION --    26260000
         BZ    BEGST1              NO, LINE ENDED WITH CR.              26280000
*                                  DEL.  CLOSE OUT FUNCTION DEFINITION. 26300000
*                                  SET UP NEW FUNCTION DIRECTORY AT MX. 26320000
         BAL   8,LINIT             INITIALIZE TRACE THROUGH ALL LINE    26340000
*                                  NUMBERS TO MOVE CODESTRING POINTERS  26360000
*                                  TO NEW DIRECTORY AND DEFINE ANY      26380000
*                                  LABELS.                              26400000
         SR    7,7                 LINE COUNTER, TIMES FOUR             26420000
CRL9     BAL   8,LINTRAC           GET NEXT ASCENDING LINE NUMBER       26440000
         B     CRL10               PAST LAST LINE                       26460000
         L     4,M(4)              NOT PAST LAST LINE.  LOAD CS PTR     26480000
         LTR   4,4                 IS LINE EMPTY --                     26500000
         BZ    CRL9                YES.  IGNORE IT.                     26520000
         L     2,MX                GET BASE ADDRESS OF DIRECTORY        26540000
         LA    7,4(7)              ADD 1 TO LINE COUNT                  26560000
         AR    2,7                                                      26580000
         LA    0,80(2)                                                  26600000
         BAL   LKR,FREECH2         ASSURE ADEQUATE SPACE FOR DIRECTORY  26620000
         ST    4,MFCODE-4(2)       PUT LINE IN DIRECTORY                26640000
         B     CRL9                                                     26660000
CRL10    L     5,MX                FINISH BUILDING THE NEW DIRECTORY    26680000
         LR    0,7                                                      26700000
         SRL   7,2                                                      26720000
         STH   7,MFLINES(5)        NEW DIRECTORY LINE COUNTER           26740000
         LM    2,3,LINAB           HAVING ASSURED OURSELVES OF ADEQUATE 26760000
         L     1,DFNPTR                                                 26780000
         L     4,M(1)              STORAGE, MARK THE OLD FUNCTION       26800000
*                                  DIRECTORY GARBAGE.                   26820000
*                                  PREPARE TO POINT CODESTRINGS TO THE  26840000
*                                  NEW DIRECTORY.  THESE SHENANIGANS    26860000
*                                  ARE BEING PERFORMED SERIALLY IN      26880000
*                                  ORDER TO PRESERVE THE PREVIOUS STATE 26900000
*                                  OF THE FUNCTION IN CASE OF AN M FULL 26920000
*                                  ERROR.                               26940000
         LTR   1,1                 NO DIRECTORY IF DFNPTR IS 0          26960000
         BZ    CRL10A                                                   26980000
         L     LKR,UNVAR                                                27020000
         ST    LKR,M(1)            FOLLOWING CODE WILL SET SYMBOL TBL   27040000
         BAL   1,MKCSG             (WE MUSTN'T CALL MKGARB -- IT WOULD  27060000
*                                  GARBAGE ALL LINES AS WELL.)          27080000
CRL10A   DS    0H                                                       27100000
         ST    2,MFLCLS(5)         STORE P/L/R WORD IN NEW DIRECTORY    27120000
         LA    2,MFCODE-M          AND LIST-OFFSET HALFWORD             27140000
         STH   2,MLSOS(5)                                               27160000
*                                  BYTE COUNT IS 4 * LINE COUNT         27180000
         AR    2,0                 PLUS OVERHEAD                        27200000
         ST    2,MCOUNT(5)                                              27220000
         LA    4,M(5)                                                   27240000
         L     1,PINAB             POINT DIRECTORY AT BST ENTRY         27260000
         ST    1,MHEAD-M(4)        AND VICE VERSA                       27300000
         MVI   MLIST-M(4),MLSTBIT                                       27320000
         OC    MHEAD-M(1,4),PROTOG INCLUDE FUNCTION PROTECTION BIT      27340000
         ST    5,M(1)              STORE DIRECTORY POINTER IN SYMBOL TB 27360000
         STC   3,M(1)              STORE FN CLASS (DFN OR DFN0) LIKEWIS 27380000
         LR    8,5                 PRESERVE A DIRECTORY POINTER         27420000
         LA    5,MFCODE-M(5)       SET UP R5 TO POINT TO LINE 0         27440000
         AR    0,5                 FINALLY GIVE MX ITS NEW VALUE        27460000
         ST    0,MX                                                     27480000
*              NOW R7 = 'COMPLEMENT' LINE NUMBER FOR BCT CLOSURE        27500000
*                  R5 = ADDR OF CODESTRING PTR IN DIRECTORY             27520000
CRL11    L     4,M(5)              PICK UP CODESTRING POINTER           27540000
         ST    5,M(4)                                                   27600000
         AR    4,MR                                                     27620000
         CLI   MCSORG-M(4),CLEOS   DOES FIRST SYL SAY 'LABEL' --        27640000
         BNE   CRL12               NO LABEL.                            27660000
         LH    4,MFPARS(8)         LABEL.                               27680000
         LA    4,16(4)             BUMP THE LABEL COUNT BY 1.           27700000
         STH   4,MFPARS(8)                                              27720000
CRL12    LA    5,4(5)              BUMP CODESTRING POINTER ADDRESS      27740000
         BCT   7,CRL11             BACK FOR NEXT LINE, OR QUIT          27760000
*                                                                       27780000
*                                                                       27800000
* CODE IN THIS VICINITY DAMAGES THE STACK                               27820000
*        UNDER THE FOLLOWING CIRCUMSTANCES,                             27840000
*              IN THIS MANNER ..                                        27860000
*                                                                       27880000
* )ERASE FN                                                             27900000
*        ALL STACKED INSTANCES OF 'FN'                                  27920000
*              CALLS DEL30, RETURNS TO BEGST2 EVENTUALLY                27940000
* HEADER EDITING                                                        27960000
*        ALL STACKED INSTANCES OF ORIGINAL DFN NAME                     27980000
*              CALLS CRL18, RETURNS THROUGH CRL LOGIC                   28000000
* LABELS SCRAMBLED, CLOSE OF DEFN OF TOP-OF-STACK DFN                   28020000
*        ALL STACKED INSTANCES OF DFN                                   28040000
*              GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3 28060000
* LABELS CHANGED, CLOSE OF DEFN OF TOP-OF-STACK DFN                     28080000
*        ALL STACKED INSTANCES OF DFN BELOW TOP LEVEL                   28100000
*              GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3 28120000
* CLOSE OF DEFN OF NON TOP-OF-STACK DFN                                 28140000
*        ALL STACKED INSTANCES OF DFN (BELOW TOP LEVEL)                 28160000
*              GOES THROUGH REVAL, CRL17, RETURNS IMMEDIATELY TO TYPIN3 28180000
*                                                                       28200000
*                                                                       28220000
*        REASSIGN VALUES TO LOCAL LABELS IF THIS FUNCTION IS SUSPENDED. 28240000
*              IN THE FOLLOWING,                                        28260000
*                  R1 = STACK POINTER TO LABEL SHADOWS                  28280000
*                  R2 = SCRATCH                                         28300000
*                  R3 = FUNCTION DIRECTORY POINTER                      28320000
*                  R4 = TRUE LINE NUMBER                                28340000
*                  R5 = REVAL1                                          28360000
*                  R6 = COMPLEMENT LINE NUMBER FOR LOOP CLOSURE         28380000
*                  R7 = CODESTRING POINTER                              28400000
*                  R8 = RELATIVE STACK POINTER                          28420000
*                                                                       28440000
REVAL    L     8,PARREL                                                 28460000
         L     3,STFNSPTR(8,MR)    COMPARE FUNCTION AT TOP OF STACK     28480000
         N     3,QF24BITS                                               28500000
         C     3,PINAB             TO NEWLY CLOSED FUNCTION.            28520000
         BNE   REVAL7              UNLIKE. IT MUSTN'T MATCH LOWER FN.   28540000
         L     3,M(3)              ADDRESS OF FN DIRECTORY              28560000
         LA    1,STSHADOW+24(8,MR) JUST BELOW FIRST LOCAL (IF ANY)      28600000
         LH    6,MFLINES(3)        SET UP TO LOOP THROUGH ALL LINES     28620000
         SR    4,4                 OF FUNCTION                          28640000
         B     REVAL3              CASE OF DISEMBODIED FUNCTION         28660000
REVAL4   LA    4,1(4)              ADVANCE LINE NUMBER                  28680000
         LA    3,4(3)              ADVANCE CODESTRING POINTER           28700000
         L     7,MFCODE(3)                                              28720000
         LA    7,3(MR,7)           STATEMENT MUST BEGIN WITH A ZLEOS    28740000
         CLI   MCSORG-M-3(7),1+2*ZLEOS                                  28760000
         BNE   REVAL3              OR IT'S NOT A LABELLED STMT.         28780000
REVAL2   LA    1,8(1)              ADVANCE TO NEXT LOCAL OR LABEL       28800000
         CLI   0(1),SHADOW+X'80'   ONLY SURE TEST FOR END OF LOCALS     28820000
         BNE   REVAL6              FAILURE -- ADDITIONAL LABELS DEFINED 28840000
         L     2,0(1)              POINTER TO SYMBOL TABLE ENTRY OF     28860000
         LA    0,0(2)              LOCAL                                28900000
         AR    2,MR                                                     28920000
         CLI   0(2),CONST          IF NOT CLASS=CONST, WE'RE NOT INTO   28940000
         BNE   REVAL2              THE LABELS YET.  CONTINUE LOOKING.   28960000
         BAL   LKR,FLOSB2          GET THE S.T. ADDR OF THE LINE LABEL  28980000
         CR    2,0                                                      29000000
         BNE   REVAL6              FAILURE -- LABELS DELETED OR SHUFFLD 29020000
         L     2,M(2)              M-ENTRY ADDR                         29040000
         C     4,MRHO(2)           COMPARE NEW TO OLD VALUE, THEN STORE 29080000
         ST    4,MRHO(2)           NEW LABEL VALUE                      29100000
         BE    REVAL3              ALL SERENE                           29120000
         OI    DSTOG,DSCLBIT       STACK DAMAGED IF FN APPEARS AGAIN    29140000
REVAL3   BCT   6,REVAL4                                                 29160000
         TM    DSTOG,DSCLBIT       DONE WITH TOP LEVEL.                 29180000
REVAL7   L     1,STFREG(8,MR)      START WITH NEXT STACK LEVEL          29200000
*                                                                       29220000
*              RAMPAGE THROUGH ALL OR PART OF THE STACK,                29240000
REVAL8   L     LKR,PINAB           DESTROYING REFERENCES TO NEWLY- 2213 29260000
         LA    8,TYPIN3            CLOSED FUNCTION.                     29280000
         BNZ   CRL19               CC MEANS DIFFERENT THINGS TO         29300000
         BR    8                   DIFFERENT PREDECESSORS               29320000
*                                                                       29340000
REVAL6   LTR   1,8                 FAILURE -- LABELS SCRAMBLED.         29360000
         B     REVAL8              REMOVE ALL REFERENCES FROM STACK     29380000
*                                                                       29400000
*              ERASE FUNCTION SPECIFIED BY R1 (= M-POINTER)             29420000
*                  R3 = SYMBOL TABLE OR STACK POINTER                   29440000
*                  R8 = RETURN ADDRESS                                  29460000
DEL30A   MVI   TUSR,0              ERASE CLASSIFICATION TOO             29480000
DEL30    ICALL MKGARB              DELETE DIRECTORY AND ALL LINES       29500000
DEL30B   LTR   LKR,3                                               2213 29520000
         BCR   8,8                                                      29540000
         L     1,UNVAR             REPLACE THE S.T. ENTRY               29560000
         ST    1,M(3)              BY AN UNDEFINED VARIABLE             29580000
*              ENTRY FROM HEADER EDITING                                29600000
CRL18    L     1,PARREL                                                 29620000
         AR    1,MR                                                     29640000
CRL17    L     2,STFNSPTR(1)       COMPARE NAME OF FN TO NAMES OF ALL   29660000
         N     2,QF24BITS          FNS ON THE STACK.                    29680000
         SR    2,LKR               DIFF=0 IF FN IS IN )SI          2213 29700000
         BNZ   CRL16                                                    29720000
         ST    2,STFNSPTR(1)       CLEAR OUT ALL REFERENCES TO THIS DFN 29740000
*                                  TO INDICATE STRICTLY IMMEDIATE       29760000
*                                  EXECUTION -- THAT IS,                29780000
*                                  DON'T TRY TO RESUME FN EXECUTION     29800000
*                                  FOLLOWING A BRANCH.                  29820000
         MVI   DSTOG,DSMSBIT       SET FLAG FOR LATER MESSAGE           29840000
CRL16    L     1,STFREG(1)         ADVANCE TO NEXT LOWER FUNCTION       29860000
CRL19    CR    1,LKR               AFTER TAKING INTO           A01 2213 29880000
         BL    CRL15               CONSIDERATION  POSSIBLE          A01 29900000
         A     LKR,QFM4            SHADOWING OF NAME           A01 2213 29920000
         L     LKR,M(LKR)                                      A01 2213 29940000
         N     LKR,QF24BITS                                    A01 2213 29960000
CRL15    BXH   1,MR,CRL17          UNLESS THIS IS END OF LIST       A01 29980000
         BR    8                                                        30000000
*                                                                       30020000
*              MARK GARBAGE THE M-ENTRY ADDRESSED INDIRECTLY BY R4.     30040000
*                  R1 = RETURN ADDR                                     30060000
MKCSGI   N     4,QF24BITS          MAY BE A FALSE ALARM                 30080000
         BCR   8,1                                                      30100000
         L     4,M(4)                                                   30120000
*              MARK GARBAGE THE M-ENTRY ADDRESSED BY R4.                30140000
MKCSG    N     4,QF24BITS                                               30160000
         BCR   8,1                 NO M-ENTRY                           30180000
         MKG   4                                                        30200000
         BR    1                                                        30220000
*                                                                       30240000
*              PRINT 'SI DAMAGE' IF THAT IS THE CASE.                   30260000
*                                                                       30280000
TYOSDCOP BAL   8,RELPNS            RELOCATE PRINTNAME FOR 'SAVED'  3575 30300000
         LA    LKR,ENDCOPY         SET EXIT FROM TYOSD             3575 30320000
TYOSD    TM    DSTOG,DSMSBIT                                            30340000
         BCR   8,LKR                                                    30360000
         MVI   DSTOG,0                                                  30380000
         TYO   DSMSG                                                    30400000
         BR    LKR                                                      30420000
*        WE WILL TYO THE CONTENTS OF THE INPUT BUFFER.             3575 30440000
*        THE INPUT BUFFER CONTAINS A MESSAGE FROM THE COPY SOURCE  3575 30460000
*        (NORMALLY, 'SAVED...', OR 'OBJECT NOT FOUND')             3575 30480000
ENDCOPY  LA    LKR,INBUF-1         GET LENGTH OF INPUT             3575 30500000
         SR    6,LKR               LINE.                           3575 30520000
         STH   6,INBUF-2           STORE LENGTH FOR TYO            3575 30540000
         TYO   INBUF-2             TYO THE INPUT LINE              3575 30560000
         MVI   COPTOG,0            TURN OFF COPY TOGGLE            3575 30580000
         B     TYPIN2              RESUME, ASKING FOR NEXT LINE    3575 30600000
DSMSG    DC    H'10',AL1(ZS,ZI,ZBLANK,ZD,ZA,ZM,ZA,ZG,ZE,ZCR,ZEOB)       30620000
         EJECT                                                          30640000
*        PRINT FUNCTION OR SINGLE-LINE DISPLAY OR NOTHING,              30660000
*        DEPENDING ON DPYTOG.  ALSO PUT A POINTER TO THE CODESTRING     30680000
*        POINTER IN PRIFT OR (IF NO CODESTRING EXISTS) LINTF.           30700000
PRIFN    ST    LKR,PRIFR                                                30720000
         BAL   8,LINIT             INITIALIZE LINE-TRACING ROUTINE      30740000
PRIF1    BAL   8,LINTRAC           GET NO. AND CODESTRING PTR PTR OF    30760000
*                                  NEXT LINE.                           30780000
         B     PRIF9               ALL DONE -- BOTH LINE NOS ARE 10**8. 30800000
*              NOW R4 = ADDRESS OF CODESTRING POINTER                   30820000
*                  R5 = LINE NUMBER OF CODESTRING                       30840000
         TM    DPYTOG,DPYALL       ARE WE DISPLAYING EVERYTHING --      30860000
         BO    PRIF7               YES.  DISPLAY THIS LINE.             30880000
         C     5,FLINENO           DISPLAYING ONLY ONE LINE.            30900000
         BL    PRIF1               SKIP PRINTING IF WE HAVEN'T REACHED  30920000
*                                  IT YET.                              30940000
         BE    PRIF6               JUST REACHED IT.                     30960000
         TM    DPYTOG,DPYPAST      PAST.  ARE WE DISPLAYING FROM N ON - 30980000
         BZ    PRIFX               NO.  REALLY PAST.                    31000000
PRIF6    ST    4,PRIFT             SAVE ADDR OF CODESTRING PTR FOR LINE 31020000
         TM    DPYTOG,DPYLIN+DPYPAST IF NO DISPLAY, WE'RE NOT PRINT-    31040000
         BZ    PRIFX               ING AT ALL, BUT SIMPLY FINDING THE   31060000
*                                  CODESTRING CORRESPONDING TO FLINENO. 31080000
PRIF7    L     2,M(4)              IF CODESTRING POINTER IS ZERO,       31100000
         LTR   2,2                 STATEMENT HAS BEEN DELETED.          31120000
         BZ    PRIF1                                                    31140000
         STM   4,5,PRIFT ,FLINENO  SAVE CODE PTR ADDR AND LINE NUMBER.  31160000
         ATT   ON=PRIF1,RESET=NO   IF ATTN, SKIP DISPLAY BUT CONTINUE   31180000
*                                  TRACING THROUGH LINE-NUMBER LISTS.   31200000
         BXH   5,5,*+8             LINE NO. 0 IS A FUNCTION HEADER.     31220000
         BAL   5,PRIFS             PRINT SPACES AND DEL OR PDEL         31240000
         BAL   LKR,OLINO           PRINT BRACKETED LINE NUMBER.         31260000
         L     3,PRIFT             RELOAD ADDRESS OF CODESTRING PTR     31280000
         BAL   LKR,COPCK           SOME INSURANCE OF REAL CODESTRING IF 31300000
         BNE   PRIF1               IT POINTS BACK TO DIRECTORY          31320000
         L     3,QFM2              NON-ERROR FLAG                       31340000
         ICALL DISPLAY             PRINT THE STATEMENT.                 31360000
         B     PRIF1                                                    31380000
PRIF9    BAL   5,PRIFS             PRINT DEL IF ENDING FN DISPLAY       31400000
         B     PRIFX                                                    31420000
         ICALL LOUT                                                     31440000
         BAL   LKR,UPLINE          UPDATE LINE NUMBER SO ANY NEW TEXT   31460000
         SR    0,0                 FOLLOWING DISPLAY REQUEST WILL       31480000
         ST    0,PRIFT             APPEND RATHER THAN REPLACE.          31500000
PRIFX    L     LKR,PRIFR           RETURN TO CALLER                     31520000
         BR    LKR                                                      31540000
*                                                                       31560000
PRIFS    TM    DPYTOG,DPYALL       THE DEL- OR PDEL-PRINTING SUBROUTINE 31580000
         BCR   8,5                                                      31600000
         LA    1,PRIDEL                                                 31620000
         CLI   PROTOG,0                                                 31640000
         BE    PRIF3                                                    31660000
         LA    1,PRIPDEL                                                31680000
PRIF3    ICALL SQUIRT                                                   31700000
         B     4(5)                                                     31720000
         EJECT                                                          31740000
*        INITIALIZE ASCENDING-LINE-NUMBER SEARCH.                       31760000
LINIT    L     2,DFNPTR            LOCATE FUNCTION DIRECTORY            31780000
         L     0,QF108                                                  31800000
         LTR   2,2                 UNLESS NEW FUNCTION, WHICH HAS NONE  31820000
         BZ    LINIT2                                                   31840000
         L     2,M(2)              R2 GIVES DIRECTORY ADDRESS           31860000
         LA    1,MFCODE-M(2)       GET ADDRESS OF CODESTRING PTR FOR    31880000
         LH    3,MFLINES(2)        LINE 0 (THE HEADER.)                 31900000
         SLA   3,2                 AND ADDRESS PAST THE LAST ENTRY      31920000
         AR    3,1                 IN THE DIRECTORY.                    31940000
         SR    0,0                 SET INTEGER LINE NO. TO 0            31960000
         SR    2,2                 SET 'LAST CODESTRING' TO EMPTY       31980000
LINIT2   ST    2,PRIFT                                                  32000000
         LA    2,HOFLN             POINT FRLNPTR TO THE FIRST FRACTION- 32020000
         SR    2,MR                AL LINE.                             32040000
         STM   0,3,ILN             SET INITIALIZED VALUES FOR LINTRAC   32060000
         BR    8                                                        32080000
*                                                                       32100000
*        FIND NEXT LARGER LINE NUMBER FROM FUNCTION DIRECTORY AND       32120000
*        FRACTIONAL-LINE-NUMBER LIST.                                   32140000
*        ON ENTRY,                                                      32160000
*              ILN = NEXT INTEGER LINE NUMBER OR 100,000,000 (END FLAG) 32180000
*              ILNPTR = ADDRESS IN FUNCTION DIRECTORY OF CODESTRING     32200000
*                       FOR LINE ILN                                    32220000
*              FRLNPTR = M-RELATIVE POINTER TO 3-WORD ITEM CONTAINING   32240000
*                                  NEXT FRLN                            32260000
*        ON EXIT,                                                       32280000
*              R4 = ADDRESS OF CODESTRING POINTER FOR THIS LINE         32300000
*              R5 = THIS LINE'S LINE NUMBER                             32320000
*        WE DEPEND ON FIRST LINE NUMBER ALWAYS BEING -1, TO GIVE LINTF  32340000
*        AN INITIAL VALUE.  TYPIN2 INITIALIZES FRACTIONAL LINE-NUMBER   32360000
*        LIST TO A SINGLE -1 ENTRY.                                     32380000
*                                                                       32400000
*        FORMAT OF FRACTIONAL-LINE-NUMBER ENTRY (DSECT FLENT)           32420000
*                                                                       32440000
*        WORD 1    POINTER TO CODESTRING M-ENTRY                        32460000
*        WORD 2    LINE NUMBER * 10000                                  32480000
*        WORD 3    POINTER TO NEXT HIGHER FRACTIONAL-LINE ENTRY, OR 0   32500000
*                                                                       32520000
DPYLIN   EQU   1                   DISPLAY SINGLE LINE OF FUNCTION      32540000
DPYALL   EQU   2                   DISPLAY ENTIRE FUNCTION              32560000
DPYNMT   EQU   4                   CURRENT CODESTRING IS NOT EMPTY      32580000
*                                  (CONTROLS LINE-NUMBER BUMPING)       32600000
DPYED    EQU   8                   CHARACTER EDITING REQUESTED          32620000
DPYPAST  EQU   16                  DISPLAY FROM LINE N TO LAST LINE     32640000
LINTRAC  LM    0,3,ILN             PICK UP ILN,ILNPTR,FRLNPTR,ENDIR     32660000
         USING FLENT,2                                                  32680000
         L     5,FLENTNO(MR)                                            32700000
         CR    0,5                 WHICH LINE NUMBER IS LARGER --       32720000
         BNL   LINT2               INTEGER, OR NEITHER.                 32740000
         LR    5,0                 FRACTIONAL.                          32760000
         A     0,F104              BUMP LINE NO. TO NEXT INTEGER.       32780000
         LR    4,1                 PICK UP ADDRESS OF CODESTRING POINTR 32800000
         LA    1,4(1)              BUMP POINTER INTO FN DIRECTORY       32820000
         CR    1,3                 ARE WE PAST THE END OF THE DIRECTORY 32840000
         BL    LINT3               NO.                                  32860000
         L     0,QF108             YES.  LOAD END FLAG TO FORCE OUT ALL 32880000
*                                  REMAINING FRACTIONAL LINE NUMBERS.   32900000
         B     LINT3                                                    32920000
*                                  FRACTIONAL LINE NO. IS LOWER.        32940000
LINT2    BCR   8,8                 QUIT NOW IF LINE NOS ARE BOTH 10**8. 32960000
         C     5,FLINENO           IF THIS LINE NUMBER IS LESS THAN     32980000
         BH    LINT4               CURRENT LINE NUMBER, SAVE ADDR OF CS 33000000
         ST    2,LINTF             WE MAY NEED IT FOR 'INSERT AFTER'    33020000
*                                  OPERATION AT CRL7.                   33040000
LINT4    LR    4,2                 RETURN ADDRESS OF CS PTR IN R4       33060000
         L     2,FLENTLNK(MR)      AND GET ADDRESS OF NEXT FRACTIONAL   33080000
         LTR   2,2                 3-WORD ENTRY, IF ANY.                33100000
         BNZ   LINT3               IF LINK=0, WE ARE OFF THE END.       33120000
         LA    2,LF108+FLENT-FLENTNO POINT R2 TOWARDS VERY LARGE NUMBER 33140000
         SR    2,MR                WHICH WILL TERMINATE SEARCH.         33160000
LINT3    STM   0,2,ILN             SAVE NEW POSITION IN I/F LINES.      33180000
         B     4(8)                                                     33200000
         DROP  2                                                        33220000
         EJECT                                                          33240000
*                                                                       33260000
*        PROTECTING DEL SCANNED.                                        33280000
PDELL    MVI   0(6),ZDEL           MAKE IT A DEL FOR REST OF CODE       33300000
         MVI   PROTOG,MFLKBIT      BUT SET PROTECT BIT AT CLOSE OF DEFN 33320000
*                                                                       33340000
*        DEL SCANNED.                                                   33360000
*                                                                       33380000
DELL     EQU   *                                                        33400000
         TM    COPTOG,COPIBIT      ARE WE A COPY SINK              3575 33420000
         BO    DELCOPY             BRANCH IF WE ARE                3575 33440000
         TM    QUADTOG,STQBIT      ARE WE IN QUAD INPUT MODE --         33460000
         BO    FNERR               YES.  NO DEFINITION ALLOWED.         33480000
DELCOPY  EQU   *                                                   3575 33500000
         CLI   FDTOG,0             IS IT AN OPENING OR CLOSING DEL --   33520000
         BNE   CDELL               CLOSING.                             33540000
         L     1,TOCORG            OPENING.  IS IT AT THE LEFT END OF   33560000
         LA    2,MCSORG+1-M(1)     THE LINE --                          33580000
         S     2,TOCPTR                                                 33600000
         BNZ   FNERR               NO.  ERROR.                          33620000
*                                  PREPARE TO LOOK (TENTATIVELY) AT HDR 33640000
         ST    2,FLINENO           LINE NUMBER IS 0                     33660000
         BAL   LKR,DELIDS          FIND AND BUILD NEXT IDENTIFIER       33680000
         B     FNERR               NO IDENTIFIER AT ALL.  ERROR.        33700000
         BAL   LKR,TOCODE2         SEND IT TO THE CODESTRING IN CASE    33720000
         MVI   FDTOG,FDDHBIT       THIS IS INITIAL DEFINITON            33740000
         LA    0,100               ASSURE ENOUGH FREE SPACE TO PERMIT   33760000
         BAL   LKR,FREECH1         CLOSING DEFINITION                   33780000
         BAL   LKR,TUSAG           FIND POSSIBLY SHADOWED S.T. ENTRY    33800000
         BAL   LKR,SKBL            ADVANCE TO NEXT NONBLANK             33820000
         CLI   0(6),ZLBR           NOW LOOK AT ALLOWABLE DELIMITERS.    33840000
         BE    DEL3                                                     33860000
         CLI   0(6),ZDEL                                                33880000
         BE    DEL3                                                     33900000
         CLI   0(6),ZPDEL                                               33920000
         BE    DEL3                MOST INSIST ON PREVIOUS DEFINITION   33940000
         LA    8,SCAN                                                   33960000
         CLI   0(6),ZCR                                                 33980000
         BCR   7,8                 UNRECOGNIZED.  ASSUME INIT DEFN.     34000000
         LA    LKR,DELCHF          CR -- MIGHT BE INIT DEFN, MIGHT NOT. 34020000
         TM    COPTOG,COPIBIT      MUST LOOK NOW FOR OLD VS NEW DEFN    34040000
         BO    DELCHA              COPY IS UNUSUAL -- IT UNDEFINES      34060000
*                                  ANY OLD DEFINITION                   34080000
         CLI   TUSR,0                                                   34100000
         BCR   8,8                 CONTINUE DEFINING IF INIT DEFINITION 34120000
*                                                                       34140000
DEL3     CLI   TUSR,2                                                   34160000
         BNE   FNERR               MUST BE NON-PENDENT FUNCTION.        34180000
         ST    3,DFNPTR            ALL SEEMS VALID.  SAVE POINTER       34200000
*                                  TO FN SYMBOL TABLE ENTRY             34220000
*                                  (WHICH MAY BE IN THE STACK)          34240000
         L     2,M(3)              AND SET UP INFO FOR EDITING AND      34260000
         L     4,MFLCLS(2)         NO. OF LOCALS AND PARAMS             34320000
         N     4,QPLMSK            NOT INCLUDING LABELS                 34340000
         LH    1,MFLINES(2)        NO. OF LINES, FOR PRINTING AS LINE   34360000
         M     0,F104                                                   34380000
         ST    1,FLINENO           NUMBER IN BRACKETS                   34400000
         IC    5,M(3)              CLASS FROM SYMBOL TABLE              34420000
         STM   3,5,PINAB           SAVE FN INFO IN ABEYANCE             34440000
         AR    2,MR                                                     34460000
         TM    MHEAD-M(2),MFLKBIT  IF LOCKED FUNCTION,                  34480000
         BO    FNERR               DISALLOW ANY EDITING.                34500000
         L     1,TOCORG            RESTORE TOCPTR TO LEFT END OF LINE   34520000
         LA    1,MCSORG-M(1)                                            34540000
         ST    1,TOCPTR                                                 34560000
         MVI   FDTOG,FDDFBIT       NOW REALLY IN DEFINITION MODE        34580000
         B     BEGST4                                                   34600000
         EJECT                                                          34620000
*                                                                       34640000
*              TRACE UP STACK AFTER GLOBAL                              34660000
*              LOCATE POSSIBLY SHADOWED GLOBAL OBJECT AND NOTE PENDENCY 34680000
*              ON ENTRY, R3 = M-RELATIVE SYMBOL TABLE POINTER           34700000
*              ON EXIT,                                                 34720000
*                  R3 = M-RELATIVE STACK OR SYMBOL TABLE POINTER        34740000
*                  R1 = SAME, ABSOLUTE                                  34760000
*                  R2 = SYMBOL TABLE POINTER OF OBJECT OR HOMONYM       34780000
*                       ( = R3 ON ENTRY)                                34800000
*                  R8 DESTROYED                                         34820000
*                  TUSR = RESULT                                        34840000
*                  TUSR = 0        UNDEFINED GLOBAL NAME                34860000
*                  TUSR = 1        GLOBAL VARIABLE                      34880000
*                  TUSR = 2        FUNCTION, NOT PENDENT                34900000
*                  TUSR = 3        FUNCTION, PENDENT                    34920000
*                  TUSR = 4        GROUP NAME                           34940000
TUSAG    MVI   TUSR,0                                                   34960000
         ST    3,TUST              SAVE FOR COMPARISONS                 34980000
         LA    1,M(3)              ASSUME SYMBOL NOT SHADOWED           35000000
         L     8,PARREL                                                 35020000
         AR    8,MR                                                     35040000
TUS1     LR    2,8                 LOOK AT LOCALS TO NEXT OUTER FN      35060000
         L     8,STFREG(8)                                              35080000
         BXLE  8,MR,TUS3           IF ANY                               35100000
         CLC   TUST+1(3),STFNSPTR+1(2) NOTE PENDENT FN IF FN ON THIS    35120000
         BNE   TUS2                LEVEL MATCHES OUR SYMBOL TABLE PTR   35140000
         TM    STFLAGS(2),STIMBIT  AND IF THE IMMEDIATE-EXECUTION       35160000
         BO    TUS2                BIT IS OFF.                          35180000
         MVI   TUSR,1                                                   35200000
TUS2     LA    2,8(2)              ADVANCE TO NEXT SHADOW               35220000
         CLI   STSHADOW(2),SHADOW+X'80' RUN THROUGH ALL SHADOWED NAMES  35240000
         BNE   TUS1                                                     35260000
         CLC   TUST+1(3),STSHADOW+1(2) COMPARE AGAINST OUR SYMBOL       35280000
         BNE   TUS2                NOT SHADOWING                        35300000
         LA    1,STPARAM(2)        SHADOWING.  THIS MAY BE GLOBAL OBJ.  35320000
         B     TUS2                                                     35340000
TUS3     SR    2,2                 NOW R1 = ADDR OF GLOBAL SYM ENTRY    35360000
         CLC   0(4,1),UNVAR        UNDEFINED VARIABLE ISN'T REALLY      35380000
         BE    TUS6                A VARB.  TUSR = 0                    35400000
         IC    2,0(1)              GET CLASS AND MAP IT TO TUS RESULT   35420000
         AGO   .APL1                                                    35440000
.APL1    ANOP                                                           35460000
TUS4     AR    2,10                                                     35480000
         OC    TUSR(1),TUSC-TYPTOP-4095(2)  = TUSC                      35500000
TUS6     LR    2,3                 RETAIN POINTER TO PRINTNAME          35520000
         LR    3,1                 RELATIVIZE GLOBAL POINTER            35540000
         SR    3,MR                                                     35560000
         BR    LKR                                                      35580000
TUSC     DC    (GROUP)FL1'0'       TUSR CODES ORDERED BY CLASS          35600000
         ORG   TUSC+1                                                   35620000
         DC    FL1'0'              UNUSED                               35640000
         ORG   TUSC+VARB                                                35660000
         DC    FL1'1'                                                   35680000
         ORG   TUSC+DFN                                                 35700000
         DC    FL1'2'                                                   35720000
         ORG   TUSC+DFN0                                                35740000
         DC    FL1'2'                                                   35760000
         ORG   TUSC+GROUP                                               35780000
         DC    FL1'4'                                                   35800000
         ORG                                                            35820000
*                                                                       35840000
*        FUNCTION LINE 0 SCANNED.  CHECK FOR VALIDITY.                  35860000
*              EARLY SYNTAX CHECK IS NORMALLY NOT DONE IN APL, BUT      35880000
*              MUST BE DONE FOR HEADERS.  WE CAN'T CLOSE A FUNCTION     35900000
*              DEFINITION UNLESS THERE'S A VALID HEADER WITH A VALID    35920000
*              FUNCTION NAME IN IT.                                     35940000
*        ALSO INSERT DUMMY PARAMETERS SO HEADER LOOKS LIKE              35960000
*              RES .= LARG FN RARG  ETC.  WITH ZEROS FOR DUMMY PARAMS   35980000
*        ON ENTRY,                                                      36000000
*              R7 = BYTE COUNT OF CODESTRING, - 1                       36020000
*              TOCORG = CODESTRING BASE ADDRESS                         36040000
*                                                                       36060000
FLOSC    EX    0,CRLM              RESET MX IN CASE OF DEFN ERROR       36080000
         A     7,TOCORG            LOCATE RH END OF CODESTRING          36100000
         LA    7,M+1(7)            ABSOLUTE                             36120000
         LA    8,10(7)             R8 REMAINS SOMEWHAT HIGHER THAN R7.  36140000
*              AS EACH SYLLABLE IS SCANNED IT IS MOVED FROM R7 TO R8    36160000
*              DUMMY SYLLABLES ARE INSERTED AS NECESSARY, MOVING R8     36180000
*              SOMEWHAT CLOSER TO R7.  AT THE END THE CODESTRING BYTE   36200000
*              COUNT IS RECALCULATED AND THE ENTIRE CODESTRING MOVED    36220000
*              DOWNWARD AGAIN TO WHERE IT SHOULD BE.                    36240000
*              THE 10-BYTE OFFSET FROM R7 TO R8 IS JUST MORE THAN       36260000
*              ENOUGH TO GUARANTEE NO OVERLAP WHEN DUMMIES ARE ADDED.   36280000
         LA    5,DFN0              R5 RECORDS THE DFN- OR DFN0-ALITY    36300000
         SR    4,4                 INITIAL LOCALS/PARAMS COUNT          36320000
FLOSC1   BAL   LKR,FLOSUB          LOOK AT NEXT SYLLABLE                36340000
         BO    FNERR               MUST BE AN IDENTIFIER                36360000
         LR    3,2                                                      36380000
         CLI   MCSORG-M-1(7),1+2*ZSEMIC                                 36400000
         BNE   FLOSC2              THIS WASN'T A LOCAL                  36420000
         LA    4,1(4)              WAS.  UP LOCALS COUNT                36440000
         BCTR  8,0                                                      36460000
         BCT   7,FLOSC1            DROP CPTR FOR SHORT SYL              36480000
FLOSC2   SLL   4,16                LOCALS COUNT IS LEFT HALFWORD        36520000
         BAL   LKR,FLOSUB          LOOK AT NEXT SYL                     36540000
         BC    14,FLOSC11          NOT A DELIMITER                      36560000
         MVC   MCSORG-M(2,8),QF2   A DELIMITER OF SOME SORT.  THIS IS   36580000
*                                  A DFN0 AND PREVIOUS SYL WAS FN NAME. 36600000
         MVC   MCSORG-M-2(2,8),MCSORG-M(7)  RE-INSERT FN NAME           36620000
         BCTR  8,0                 BUMP R8 OVER DUMMY RIGHT ARG         36640000
         BCT   8,FLOSC12           AND JOIN NO-LEFT-ARG CODE.           36660000
FLOSC11  LA    5,DFN               THIS ID IS FN NAME, AND IT'S A DFN.  36680000
         AH    4,QH1               BUMP PARAM COUNT                     36700000
         LR    3,2                 SAVE FN SYLLABLE                     36720000
         BAL   LKR,FLOSUB          ADVANCE PAST LEFT ARG, IF ANY        36740000
         BC    14,FLOSC8                                                36760000
FLOSC12  MVC   MCSORG-M-3(3,8),FLOSAZ  NO LEFT ARG.                     36780000
         BCTR  8,0                                                      36800000
         BCT   8,FLOSC3            BUMP R8 OVER DUMMY LEFT ARG          36820000
FLOSC8   AH    4,QH1               LEFT ARG EXISTS.  PARAM COUNT IS 2   36840000
FLOSC3   CLI   MCSORG-M-1(7),1+2*ZLARROW                                36860000
         BNE   FLOSC9              NO RESULT PARAMETER                  36880000
         BCTR  7,0                 BUMP CPTR PAST LEFT ARROW            36900000
         BCTR  8,0                                                      36920000
         BAL   LKR,FLOSUB                                               36940000
         BO    FNERR               MUST BE A NAME                       36960000
         B     FLOSC4                                                   36980000
FLOSC9   MVC   MCSORG-M-4(4,8),FLOSCS  DUMMY RESULT & DECORATIONS       37000000
         S     8,QF3                                                    37020000
FLOSC4   CLI   MCSORG-M-1(7),1+2*ZEOS  WE MUST BE AT BEGINNING OF LINE  37040000
         BNE   FNERR               ERROR IF NOT.                        37060000
         L     2,TOCORG            RECOMPUTE SYLLABLE COUNT AND BYTE    37080000
         SR    7,8                 COUNT.                               37100000
         LA    1,10(7)             R1 = NO. OF ADDED BYTES              37120000
         AH    1,MCSCNT(2)         PLUS ORIGINAL NO. OF SYLLABLE BYTES  37140000
         STH   1,MCSCNT(2)                                              37160000
         LA    LKR,MCSORG-M+3(1)   PLUS OVERHEAD                        37180000
         N     LKR,QFM4            ROUNDED UP TO WORD BDY               37200000
         ST    LKR,MCOUNT(2)                                            37220000
         AR    LKR,2               TO CORRECT MX TO POINT TO END OF     37240000
*                                  M-ENTRY                              37260000
FLOSC10  IC    0,MCSCNT-M+1(8)     NOW MOVE CODESTRING LEFTWARD.  R7    37280000
         STC   0,MCSCNT-M+1(7,8)   IS DIFF BETWEEN PRESENT AND CORRECT  37300000
         LA    8,1(8)              POINT, AND R8 POINTS (OFFSET) TO     37320000
*                                  WHERE CODESTRING IS NOW.             37340000
         BCT   1,FLOSC10           MVC LOOP IS TOO DIFFICULT            37360000
         LR    7,LKR               SAVE NEW MX VALUE OVER TUSAG         37380000
         C     3,DFNPTR            IF NEW FN NAME IS SAME AS OLD,       37400000
*                                  (NEVER TRUE ON INITIAL DEFINITION)   37420000
         BE    FLOSC5              WE'RE OKAY.                          37440000
         BAL   LKR,TUSAG           OTHERWISE, CHECK THAT NAME IS NOT    37460000
         LA    LKR,DELCHF                                               37480000
         BAL   8,DELCHA            THAT OF SOME OTHER QUANTITY          37500000
FLOSC5   STM   3,5,PINAB           SAVE ALL THIS FOR FUNCTION CLOSE     37520000
         ST    7,MX                FINALLY SET NEW MX VALUE             37540000
         L     3,DFNPTR                                                 37560000
         LTR   LKR,3                                               2213 37580000
         BZ    *+8                                                      37600000
         BAL   8,CRL18             MAKE ORPHANS OF STACKED LOCALS       37620000
         NI    FDTOG,FDCLBIT       NOW TRULY IN FN-DEFINITION MODE      37640000
         OI    FDTOG,FDDFBIT       ALTHOUGH PERHAPS ON THE WAY OUT      37660000
         L     7,SCSCNT            RESTORE CODESTRING COUNT TO R7       37680000
         BCT   7,CRL5B             AND REJOIN END-OF-STATEMENT LOGIC    37700000
*        FETCH A LONG SYLLABLE FROM CODESTRING                          37720000
*        INCIDENTALLY MOVE 3 BYTES INTO NEW CODESTRING (R8) AREA        37740000
*        RETURNS SYMBOL TABLE ADDRESS IN R2                             37760000
*        CONDITION CODE IS 3 IF NOT A LONG SYLLABLE, 2 OTHERWISE        37780000
*        R7 AND R8 DECREASED BY 2 IF LONG SYLLABLE                      37800000
FLOSUB   MVC   MCSORG-M-3(3,8),MCSORG-M-3(7)  MOVE POSSIBLE LONG SYL    37820000
*                                  (PLUS POSSIBLE SHORT SYL) TO R8 AREA 37840000
         TM    MCSORG-M-1(7),1     TEST FOR SHORT SYL                   37860000
         BCR   1,LKR               NO ACTION IF SHORT                   37880000
         A     8,QFM2                                                   37900000
FLOSB2   MVC   FTEMP1(2),MCSORG-M-2(7)  MOVE IN 16-BIT SYLLABLE         37920000
         LH    2,FTEMP1                                                 37940000
         SLA   2,2                 QUADRUPLE SYLLABLE                   37960000
         A     2,QR13STK           AND GET OFFSET FROM TOP OF S.T.      37980000
         BCTR  7,0                                                      38000000
         BCTR  7,LKR                                                    38020000
         SPACE 2                                                        38040000
FLOSAZ   DC    AL1(1+2*ZLARROW,0,0)                                     38060000
FLOSCS   DC    AL1(1+2*ZEOS,0,0,1+2*ZDUM)                               38080000
         SPACE 2                                                        38100000
DELIDS   DC    0H'0'                                                    38120000
         ST    LKR,DELIT                                                38140000
         BAL   LKR,SKBLI           BUMP INPUT PTR AND LOOK AT NEXT      38160000
         L     LKR,DELIT                                                38180000
         CLI   0(6),ZA             NONBLANK.                            38200000
         BCR   4,LKR               IT'S TOO LOW TO BE ALPHA             38220000
         CLI   0(6),ZDELTAU                                             38240000
         BCR   2,LKR               OR TOO HIGH                          38260000
         BAL   LKR,SRCHID          IT'S JUST RIGHT.  BUILD ID.          38280000
         L     LKR,DELIT                                                38300000
         B     4(LKR)                                                   38320000
         EJECT                                                          38340000
*                                                                       38360000
*        CHECK DEFINITION STATUS OF GLOBAL                              38380000
*              ALLOW REDEFINITION ONLY IF WE ARE SINK FOR AN            38400000
*              UNPROTECTING )COPY OPERATION.                            38420000
*              RETURNS TO  0(8)  IF OK TO REDEFINE (POSSIBLY AFTER      38440000
*              HAVING DESTROYED THE PRESENT DEFINITION.)  ELSE,         38460000
*              EXITS TO FNERR (NOT COPY MODE) OR BEGST2 (COPY MODE),    38480000
*              IN THE LATTER CASE AFTER IGNORING THE NEW OBJECT.        38500000
*              ON ENTRY,                                                38520000
*                  R2 = M-RELATIVE SYMBOL TABLE POINTER                 38540000
*                  R3 = M-RELATIVE GLOBAL STACK/SYMBOL POINTER          38560000
*                  LKR = ADDR OF IGNORING ROUTINE                       38580000
*                  TUSR = CLASSIFICATION, FROM TUSAG                    38600000
*                                                                       38620000
DELCHA   CLI   TUSR,0                                                   38640000
         BCR   8,8                                                      38660000
         TM    COPTOG,COPIBIT+COPPBIT  ELSE, IF NOT )COPY'ING,          38680000
         BZ    FNERR               DEFN ERROR                           38700000
         L     1,M(3)                                                   38720000
         BM    DEL30A              OR IF )PCOPY, 'NOT COPIED'           38740000
         S     2,QR13STK           MARK THIS OBJECT IN THE 'NOT COPIED' 38760000
*        'NOT COPIED' MARK IN SYMBOL TABLE GOES HERE                    38780000
         LA    7,BEGST2                                                 38800000
         EX    0,ZDFNPTR                                                38820000
*                                  NOW FOR THE TEDIOUS BUSINESS OF      38840000
         BR    LKR                 IGNORING THE DEFINITION, WHICH THE   38860000
*                                  SOURCE IS BOUND AND DETERMINED TO    38880000
*                                  SEND US.                             38900000
DELCHF   BAL   LKR,EOBSB2          FUNCTION.  IGNORE UNTIL              38920000
         CLC   0(5,6),PRIDEL+1     WE SEE SPACES AND A DEL              38940000
         BCR   8,7                                                      38960000
         CLC   0(5,6),PRIPDEL+1    OR SPACES AND A PDEL                 38980000
         BCR   8,7                                                      39000000
         B     DELCHF              NOTE AMUSING BUG IN ABOVE            39020000
DELCHG   BALR  LKR,0               IGNORE A GROUP DEFINITION            39040000
         CLI   0(6),ZCR                                                 39060000
         BCR   8,7                                                      39080000
         B     SKBLI                                                    39100000
 TITLE 'S Y S T E M   C O M M A N D S   - -   S I G N   O N'            39120000
SOPROC   CLI   0(6),ZRPAR          FIRST NONBLANK MUST BE A RIGHT PAREN 39140000
         BNE   SOPERR              INDICATING A SYSTEM COMMAND          39160000
         BAL   LKR,SKBLI                                                39180000
         BAL   LKR,ININT           CONVERT THE NUMBER FOLLOWING THE )   39200000
         DC    Y(SOPERR-TYPTOP,SOP1-TYPTOP)                             39220000
         L     1,DTEMP             COMPUTE MANHASH RESIDUE MANNUMBER    39240000
         C     1,PUBPRI            CHECK FOR SIGNON WITH PUBLIC LIBRARY 39260000
         BL    SOPFAIL             NUMBER. (VERBOTEN)                   39280000
         SR    0,0                 TO SEE IF MANNUMBER IS IN THIS       39300000
         L     2,=A(KMANHASH)                                           39320000
         D     0,0(2)              DIRECTORY.  NO USE SEARCHING WRONG   39340000
         CL    0,WFLMAN            DIRECTORY.  (DIR NO. IN LOW M)       39360000
         BNE   CMLEMP              WRONG DIRECTORY, GET CORRECT ONE     39380000
         BAL   LKR,SKBL            LOOK FOR SIGNON PASSWORD             39400000
         BAL   8,PASSUB                                                 39420000
         NOP   0                   NO PASSWORD                          39440000
         CLI   0(6),ZCR            MUST BE END OF TEXT                  39460000
         BNE   SOPERR                                                   39480000
*        RESCAN SIGN-ON USING PROPER DIRECTORY                          39500000
         L     2,MANSTAR           GOT A MAN NUMBER.  SEARCH FOR IT IN  39520000
         LA    3,MANENTL           THE TABLE OF USERS IN M.             39540000
         L     4,DTEMP                                                  39560000
SOP2     LA    5,M(2)              R5 IS ABS ADDRESS OF MAN ENTRY       39580000
         TM    LIBNUM-PERLIB(5),X'80'  NEGATIVE MAN NUMBER              39600000
         BO    SOPFAIL             SIGNALS END OF TABLE.                39620000
         C     4,LIBNUM-PERLIB(5)                                       39640000
         BNE   SOP3N               DOES MAN NO. MATCH THE ONE TYPED --  39660000
         CLC   SOPASS-PERLIB(8,5),NEWID  DO PASSWORDS MATCH --          39680000
         BE    SOP3                YES.                                 39700000
         B     SOPFAIL             NO, NO SENSE LOOKING ANY MORE        39720000
SOP3N    BXH   2,3,SOP2            TRY NEXT MAN ENTRY                   39740000
SOPFAIL  TYO   SOPFTXT             MAN NUMBER NOT IN TABLE.  TELL HIM   39760000
         B     BEGST2              SO.                                  39780000
SOPERR   TYO   SOPERTX             INCORRECT SIGN-ON                    39800000
         B     BEGST2                                                   39820000
SOPDUP   TYO   SOPDTXT             MAN NUMBER DUPLICATES SIGNED-ON USER 39840000
         B     BEGST2                                                   39860000
SOPLOCK  TYO   SOPLKTX             SEND 'NUMBER LOCKED OUT' MESSAGE     39880000
         B     BEGST2                                                   39900000
         AGO   .SOX2                                                    39920000
.SOX2    ANOP                                                       SOX 40500000
SOP3     ST    2,NTEMP             NUMBER FOUND.  SEE IF HE'S ALREADY   40520000
         BAL   LKR,SOPSUB          SIGNED ON.                           40540000
         B     SOPDUP              ALREADY ON.                          40560000
         AR    2,MR                                                     40580000
         TM    PLMISC-PERLIB(2),LIBLOCK  IS LOCKOUT BIT ON              40600000
         BO    SOPLOCK             YES.  POOR GUY WON'T GET SIGNED ON.  40620000
         SR    1,1                                                      40640000
         L     8,MPTBASE                                                40660000
         CL    4,OPMAN             CHECK FOR OPERATOR'S MAN NUMBER      40680000
         BNE   SOP4B                                                    40700000
         SVRAPE                    ,REMEMBER OPTERM FOR TYPEIN'S USE    40720000
         ST    8,OPTERM                                                 40740000
         LA    1,1                 PARAMETER TO SOOK                    40760000
*        SOOK PARAMETERS..                                              40780000
*              R1 = 1 INDICATES SIGN ON OF OPERATOR                     40800000
*              R2 = USING PERLIB,2   (ABSOLUTE ADDRESS)                 40820000
SOP4B    TCOM  SOOK                TELL APLSUP SIGNON IS OK             40840000
SOPD     L     4,OPMAN             IF OPERATOR IS ALREADY SIGNED ON,    40860000
         BAL   LKR,SOPSUB                                               40880000
*                                                                       40900000
         B     SOP4C               FINE.  PRINT SIGNON MESSAGE.         40920000
SOP4D    TCOM  DELAY,1500          DELAY HERE UNTIL OP WELL SIGNED ON   40940000
         ATT   OFF=SOPD,ON=CMOFFZ  ATTENTION SIGNS HIM OFF FAST         40960000
*                                  NOW PRINT SIGN-ON MESSAGE TO OPERATR 40980000
*        THE FORMAT IS     TTT) HH.MM.SS MM/DD/YY USERNAME NNNNNN       41000000
SOP4C    LA    2,OBUF                                                   41020000
         BAL   LKR,CVTERM          PRINT TERMINAL NUMBER                41040000
         MVI   OBUFPTR+1,3                                              41060000
         ICALL GETIME              PRINT TIME OF DAY                    41080000
         LR    3,1                 TIME TO R3 FOR PRINTTIME.            41100000
         L     6,OPTERM            IF THIS ISN'T THE OPERATOR SIGNING   41120000
         CL    6,MPTBASE           ON,                                  41140000
         BE    SOP4E                                                    41160000
         L     0,F104              GIVE OPERATOR APPROX 30-SEC GRACE    41180000
         A     0,PTSOTM-PERTERM(6) PERIOD AFTER SIGNON TO LOAD OPFNS,   41200000
         CLR   0,3                 SET UP A )HI MESSAGE, ETC.           41220000
         BNL   SOP4D                                                    41240000
SOP4E    BAL   8,PRINTIME                                               41260000
         BAL   8,PRINTDAT          PRINT TODAY'S DATE                   41280000
         L     1,NTEMP             PRINT USER NAME                      41300000
         IC    0,PLMISC-PERLIB(1,MR)   SAVE AUTO-FLAG                   41320000
         STC   0,NTEMP+2                                                41340000
         LA    1,HISNAME-PERLIB(1,MR)                                   41360000
         ICALL SQUIRT                                                   41380000
         MVC   NTEMP(2),OBUFPTR    SAVE LINE LENGTH W/O MAN NUMBER      41400000
         ICALL DIREMP              CLEAR WS                             41420000
         MVI   OBUF+3,ZRPAR        PLANT <RPAR>                         41440000
         ICALL LOUT                SEND SIGN-ON MSG TO USER             41460000
         MVC   OBUFPTR(2),NTEMP    RESTORE LINE LENGTH W/O MAN NUMBER   41480000
         LA    1,ZBLANK                                                 41500000
         ICALL TOPRINT                                                  41520000
         L     0,DTEMP             PRINT MAN NUMBER                     41540000
         ICALL PRNUM                                                    41560000
         LH    1,OBUFPTR           THIS NONSENSE KEEPS USERS OF TRUE    41580000
*                                  A N D  SS COUNTS HAPPY               41600000
         LA    1,1(1)                                                   41620000
         STH   1,OBUFPTR                                                41640000
         AR    1,MR                                                     41660000
         MVC   OBUF-M-1(2,1),QZCREOB                                    41680000
         L     4,MPTBASE                                                41700000
         C     4,OPTERM            AVOID THE OTHER SIGN-ON OUTPUT       41720000
         BE    SOP5                IF THIS IS THE OPERATOR.             41740000
         TCOM  LOG,OBUFPTR         TELL OPERATOR ABOUT SIGN ON          41760000
         L     1,=A(SOOKTXT)                                            41780000
         TM    IOB2-PERTERM(4),LOEXP   EXPRESS VS NORMAL PORT           41800000
         BZ    *+8                 NORMAL PORT                          41820000
         L     1,=A(SOOKEXTX)      EXPRESS PORT                         41840000
         TYO   0(1)                AND THE FINAL LINE 'APL EXPAND'      41860000
SOP5     MVI   OBUFPTR+1,0                                              41880000
         TM    NTEMP+2,LIBAUTOL    IF NO AUTO-LOAD,                     41900000
         BZ    TYPIN2              START EXECUTING.                     41920000
         EX    0,ZDFNPTR           CLEAR FN DEFN TOGGLES, ETC.     3034 41940000
         EX    0,INITHOFL           IN CASE AUTO-LOAD FAILS.       3034 41960000
         MVC   SVIT(4),SVI                                         3034 41980000
         EX    0,SYSC12                                                 42000000
         MVC   PDSWSN-PDSLIB+OURSDP(13),SPDSAVE  ELSE FAKE A )LOAD      42020000
         MVI   PDSOPA-PDSLIB+OURSDP,XXLOAD                              42040000
         MVC   PDSLIB-PDSLIB+OURSDP(4),DTEMP  THIS MAN NUMBER           42060000
         B     SPDISK                                                   42080000
SOP1     CLC   0(3,6),SYSCOPR      NEXT 3 CHARS HAD BETTER BE       SOX 42120000
         AGO   .SOX4                                                SOX 42140000
.SOX4    ANOP                                                       SOX 42240000
         BNE   SOPERR              'OPR'                                42260000
         LA    6,4(6)              BUMP INPUT POINTER PAST 'OPR '       42280000
         BAL   LKR,SKBL            GET FIRST NONBLANK OF MESSAGE        42300000
         MVI   SCNO,1                                                   42320000
         B     CMOPR                                                    42340000
*                                  SEE IF USER WITH NUMBER IN R4 IS     42360000
SOPSUB   L     6,=A(SUPPARS)       SIGNED ON                       2230 42380000
         LM    6,8,PTBXLE-SUPPARD(6)                               2230 42400000
SOP4     TM    IOB1-PERTERM(8),NSIGNM                                   42420000
         BO    SOP4A                                                    42440000
         C     4,PTMAN-PERTERM(8)                                       42460000
         BCR   8,LKR               RETURN TO 0(LKR) IF HE IS            42480000
SOP4A    BXLE  8,6,SOP4            INDEX THROUGH ALL PERTERMS           42500000
         B     4(LKR)              RETURN TO 4(LKR) OTHERWISE           42520000
         SPACE 2                                                        42540000
CMDNUMBR TYO   SOPNDTXT            SEND 'ALREADY SIGNED ON' MESSAGE     42560000
         B     BEGST2                                                   42580000
 TITLE 'S Y S T E M   C O M M A N D S   - -   S C A N N E R'            42600000
SYSCMD   BAL   LKR,SKBLI           SKIP TO START OF COMMAND             42620000
         BAL   LKR,ININT           SEE IF THIS FORGETFUL CHAP IS TRYING 42640000
         DC    Y(CMDERR-TYPTOP,SYSC0-TYPTOP)  SIGN ON AGAIN             42660000
         B     CMDNUMBR            IF HE IS, SLAP HIS WRIST             42680000
SYSC0    BAL   LKR,BLDID           GET COMMAND NAME IN NEWID        SOX 42720000
         AGO   .SOX6                                                SOX 42740000
.SOX6    ANOP                                                       SOX 42840000
         LM    1,3,SCSCH           PREPARE TO SEARCH TABLE OF COMMANDS  42860000
SYSC1    CLC   NEWID(4),SCNAME-SCIMAGE(1)  FOR MATCH WITH FIRST 4 CHARS 42880000
         BE    SYSC2                                                    42900000
         BXLE  1,2,SYSC1           BACK FOR NEXT ENTRY OR QUIT          42920000
CMDERR   TYO   BADCOM              WITH BAD COMMAND MESSAGE.            42940000
         B     CMEND2                                                   42960000
SYSC2    MVC   SCIMAGE(8),0(1)     SAVE COMMAND CONTROL INFO            42980000
SYSC12   XC    OURSDP(PDSLEN),OURSDP   CLEAR SPACE FOR SPDISK PARS      43000000
         MVC   PDSOPA-PDSLIB+OURSDP(1),SCNO   INSERT SPDISK OP          43020000
         TM    SCFLG,SCINFN        IS THIS COMMAND ALLOWED IN FN-DEFN - 43040000
         BO    SYSC3               YES.                                 43060000
         TM    FDTOG,FDDFBIT+FDDHBIT NO.  ARE WE IN FN-DEFINITION --    43080000
         BNZ   CMDINFN             YES.  ERROR.                         43100000
SYSC3    TM    SCFLG,SCPRIV        IS THIS A PRIVILEGED COMMAND --      43120000
         BZ    SYSC4               NO. LET HIM USE IT.                  43140000
         L     1,=A(SUPPARS)       YES. IS USER PRIVILEGED         2230 43160000
         L     1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE  2230 43180000
         TM    IOB1-PERTERM(1),PRIVBIT                                  43200000
         BZ    CMDERR                                                   43220000
SYSC4    BAL   LKR,SKBL            MOVE TO BEGINNING OF POSSIBLE ARG    43240000
         TM    SCFLG,SCARG1        IS THERE SUPPOSED TO BE ONE --       43260000
         BZ    SYSC10              NO.  CHECK FOR POSSIBLE SECOND ARG   43280000
         BAL   LKR,ININT           YES.  BUILD INTEGER.                 43300000
         DC    Y(CMDERR-TYPTOP,SYSC6-TYPTOP)                            43320000
         L     1,DTEMP                                                  43340000
         LTR   1,1                                                      43360000
         BM    CMDERR                                                   43380000
         CLI   0(6),ZBLANK         BLANK OR CR MUST FOLLOW              43400000
         BE    SYSC5                                                    43420000
         CLI   0(6),ZCR                                                 43440000
         BNE   CMDERR                                                   43460000
         B     SYSC5                                                    43480000
SYSC6    TM    SCFLG,SCIMP1        IS AN IMPLICIT FIRST ARG OK --       43500000
         BZ    CMDERR              NO. JUST PLAIN WRONG.                43520000
         NI    SCFLG,255-SCARG1    INDICATE ARGUMENT 1 OMITTED          43540000
         L     1,=A(SUPPARS)       YES.  IMPLIED ARG IS USER NO.   2230 43560000
         L     1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE  2230 43580000
         L     1,PTMAN-PERTERM(1)                                       43600000
SYSC5    ST    1,PDSLIB-PDSLIB+OURSDP                                   43620000
         BAL   LKR,SKBL            MOVE TO SECOND ARG, IF ANY           43640000
SYSC10   TM    SCFLG,SCARG2        IS THERE A SECOND ARG --             43660000
         BZ    SYSC9               NO.  CHECK FOR END OF COMMAND.       43680000
         CLI   0(6),ZDELTAU        YES.  MUST START WITH 'ALPHA' CHAR   43700000
         BH    SYSC7                                                    43720000
         BAL   LKR,BLDID           BLDID WILL TEST FOR ALPHANUMERIC     43740000
         CL    5,QF11                                                   43760000
         BNH   *+8                 IGNORE CHARACTERS PAST 11TH          43780000
         LA    5,11                                                     43800000
         STC   5,PDSWSN-PDSLIB+OURSDP    SAVE CHARACTER COUNT           43820000
         LTR   5,5                 WAS THERE A NAME --                  43840000
         BZ    SYSC7               NO.                                  43860000
         BCTR  5,0                                                      43880000
         EX    5,SYSMV             MOVE SECOND ARG INTO PARAM AREA      43900000
         B     SYSC8                                                    43920000
SYSMV    MVC   PDSWSN-PDSLIB+OURSDP+1(0),0(7)                           43940000
SYSC7    TM    SCFLG,SCIMP2        NEED THERE BE A SECOND ARG --        43960000
         BZ    CMDERR              YES.  ERROR.                         43980000
         NI    SCFLG,255-SCARG2    INDICATE ARGUMENT 2 OMITTED          44000000
SYSC8    BAL   LKR,SKBL                                                 44020000
         TM    SCFLG,SCPASS        MAY THERE BE A PASSWORD --           44040000
         BZ    SYSC9               NO.                                  44060000
         BAL   8,PASSUB            COLLECT THE PASSWORD                 44080000
         B     SYSC9               NO PASSWORD                          44100000
SYSC11   MVC   PDSPASS-PDSLIB+OURSDP(8),NEWID                           44120000
         LTR   5,5                 FOR )OFF AND )CONTINUE,              44140000
         BNZ   *+8                 DISTINGUISH BETWEEN NO PASSWORD AND  44160000
         MVI   NEWID,X'FF'         EMPTY PASSWORD.                      44180000
SYSC9    LA    LKR,CMDERR          LET EXECUTION ROUTINES USE BCR'S     44200000
         TM    SCFLG,SCADD         MAY OTHER SPECIAL-PURPOSE ARGUMENTS  44220000
         BO    SYSTO               BE PRESENT --                        44240000
         CLI   0(6),ZCR            NO.  NEXT CHAR MUST BE A CR.         44260000
         BCR   7,LKR                                                    44280000
SYSTO    LH    2,SCAD              TAKE OFF TO THE COMMAND ROUTINE      44300000
         MVC   NTEMP(5),PDSWSN-PDSLIB+OURSDP SAVE 'HOLD' FOR )OFF       44320000
*                                  AND )CONTINUE                        44340000
         L     1,PDSLIB-PDSLIB+OURSDP                                   44360000
*        BRANCH TO COMMAND EXECUTION ROUTINE                            44380000
*              SCIMAGE CONTAINS CMD BLOCK, R1 CONTAINS FIRST ARG        44400000
*              R6 POINTS TO 1ST NONBLANK FOLLOWING LAST ARG COLLECTED   44420000
         B     SYSTO(2)                                                 44440000
CMDINFN  TYO   NOTINFN                                                  44460000
         B     BEGST2                                                   44480000
 TITLE 'S Y S T E M   C O M M A N D S   - -   T A B L E'                44500000
SCSCH    DC    A(SYSCTXT,8,SYSCTND)                                     44520000
SYSCTXT  DC    0F'0'                                                    44540000
*        INQUIRY COMMANDS                                               44560000
         CMD   FNS,CMFNS,0,SCINFN+SCARG2+SCIMP2                         44580000
         CMD   VARS,CMVARS,0,SCINFN+SCARG2+SCIMP2                       44600000
         CMD   GRPS,CMGRPS,0,SCINFN+SCARG2+SCIMP2                       44620000
         CMD   GRP,CMGRP,0,SCINFN+SCADD                                 44640000
         CMD   LIB,SPDISK,XXLIB,SCINFN+SCARG1+SCIMP1                    44660000
         CMD   SI,CMSI,0,SCINFN                                         44680000
         CMD   SIV,CMSI,1,SCINFN                                        44700000
*                                                                       44720000
*        WORKSPACE CONTROL COMMANDS                                     44740000
         CMD   ORIG,CMORG,0,SCINFN+SCARG1                               44760000
         CMD   DIGI,CMDIGI,0,SCINFN+SCARG1                              44780000
         CMD   WSID,CMWSID,0,SCINFN+SCARG1+SCIMP1+SCARG2+SCIMP2         44800000
         CMD   WIDT,CMWIDT,0,SCINFN+SCARG1                              44820000
         CMD   ERAS,CMERA,0,SCINFN+SCADD                                44840000
         CMD   CLEA,CMCLEAR,0,SCINFN                                    44860000
         CMD   COPY,CMCOPY,COPIBIT,SCARG1+SCIMP1+SCARG2+SCPASS+SCADD    44880000
         CMD   PCOP,CMCOPY,COPIBIT+COPPBIT,SCARG1+SCIMP1+SCARG2+SCPASS+.44900000
               SCADD                                                    44920000
         CMD   LOAD,SPDISK,XXLOAD,SCINFN+SCARG1+SCIMP1+SCARG2+SCPASS    44940000
         CMD   GROU,CMGROU,0,SCINFN+SCADD                               44960000
         CMD   SYMB,CMSYMB,0,SCARG1                                     44980000
*                                                                       45000000
*        LIBRARY CONTROL COMMANDS                                       45020000
         CMD   SAVE,CMSAVE,XXSAVE,SCARG1+SCIMP1+SCARG2+SCIMP2+SCPASS    45040000
         CMD   DROP,SPDISK,XXDROP,SCINFN+SCARG1+SCIMP1+SCARG2           45060000
*                                                                       45080000
*        TERMINAL CONTROL COMMANDS                                      45100000
         CMD   OFF,CMOFF,XXOFF,SCINFN+SCARG2+SCIMP2+SCPASS              45120000
         CMD   CONT,CMCONT,XXOFF,SCARG2+SCIMP2+SCPASS                   45140000
*                                                                       45160000
*        COMMUNICATION COMMANDS                                         45180000
         CMD   MSG,CMMSG,1,SCINFN+SCARG1+SCIMP1+SCADD                   45200000
         CMD   MSGN,CMMSG,0,SCINFN+SCARG1+SCIMP1+SCADD                  45220000
SYSCOPR  CMD   OPR,CMOPR,1,SCINFN+SCADD                                 45240000
         CMD   OPRN,CMOPR,0,SCINFN+SCADD                                45260000
         CMD   PORT,CMPORT,0,SCINFN+SCARG2+SCIMP2                       45280000
*                                                                       45300000
*        COMMUNICATION COMMANDS (OPERATOR)                              45320000
         CMD   HIPA,CMOPR,3,SCINFN+SCPRIV+SCADD                         45340000
         CMD   PA,CMOPR,2,SCINFN+SCPRIV+SCADD                           45360000
         CMD   HI,CMOPR,4,SCINFN+SCPRIV+SCADD                           45380000
*                                                                       45400000
*        SYSTEM ADMINISTRATION COMMANDS (OPERATOR)                      45420000
         CMD   ADD,CMADD,XXADD,SCINFN+SCPRIV+SCARG1+SCARG2+SCADD+SCPASS 45440000
         CMD   DELE,CMDELE,XXDEL,SCINFN+SCPRIV+SCARG1                   45460000
         CMD   LOCK,SPDISK,XXLOCK,SCINFN+SCPRIV+SCARG1                  45480000
         CMD   UNLO,SPDISK,XXUNLK,SCINFN+SCPRIV+SCARG1                  45500000
SYSCTND  EQU   *-4                                                      45520000
             SPACE 2                                                    45540000
*              BITS IN SCFLG                                            45560000
SCPRIV   EQU   X'80'               PRIVILEGED COMMAND                   45580000
SCINFN   EQU   X'40'               COMMAND ALLOWED IN FN-DEFINITION     45600000
SCARG1   EQU   X'20'               COMMAND HAS (NUMERIC) 1ST ARGUMENT   45620000
SCIMP1   EQU   X'10'               1ST ARGUMENT MAY BE OMITTED          45640000
SCARG2   EQU   X'08'               COMMAND HAS (ALPHA) 2ND ARGUMENT     45660000
SCIMP2   EQU   X'04'               2ND ARGUMENT MAY BE OMITTED          45680000
SCPASS   EQU   X'02'               COMMAND MAY HAVE PASSWORD            45700000
SCADD    EQU   X'01'               COMMAND MAY HAVE ADDITIONAL ARGUMENT 45720000
 TITLE 'S Y S T E M   C O M M A N D S   - -   M E S S A G E S'          45740000
*                                                                       45760000
*              SEND MESSAGE TO OPERATOR OR TO ANOTHER PORT              45780000
*                                                                       45800000
CMMSG    TM    SCFLG,SCARG1        IF ARG WAS PRESENT,                  45820000
         BZ    CMMS1                                                    45840000
         LTR   1,1                 IT MUST BE POSITIVE.                 45860000
         BNZ   CMMS2               TERM 0 IS SPECIAL GLITCH FOR LOGGING 45880000
         LA    1,4000              AVAILABLE ONLY INTERNALLY            45900000
         B     CMMS2                                                    45920000
CMMS1    CLC   0(3,6),SYSCOPR      IF NO PORT NUMBER, ONLY ALTERNATIVE  45940000
         BNE   CMDERR              IS 'OPR '                            45960000
         LA    6,3(6)              SKIP OPR TEXT                        45980000
CMOPR    SR    1,1                 )OPR -- SEND MESSAGE TO OPERATOR     46000000
CMMS2    S     6,QF7                                                    46020000
*                                  BUMP INPUT POINTER BACK TO PROVIDE   46040000
         MVI   6(6),ZBLANK                                              46060000
         N     6,QFM2              SPACE FOR SENDER'S TERMINAL NO. AND  46080000
         LA    2,2(6)                                                   46100000
         BAL   LKR,CVTERM          THE CHARACTER COUNT (A HALFWORD).    46120000
         MVI   5(6),ZCOLON         FOLLOW TERM NO BY A COLON            46140000
         MVI   6(6),ZBLANK         FOLLOW COLON BY BLANK                46160000
         CLI   SCNO,1                                                   46180000
         BNE   CMOP1               OR, IF REPLY IS EXPECTED,            46200000
         CLI   0(2),ZO             AND SENDER IS NOT THE OPERATOR,      46220000
         BE    CMOP1                                                    46240000
         MVI   6(6),ZRU            BY 'R'                               46260000
CMOP1    L     3,INLCH             INLCH IS ADDR PAST LAST CHAR OF MESS 46280000
         SR    3,2                 FIND NO. OF CHARS IN MESSAGE         46300000
         CH    3,QH126             TRUNCATE MESSAGES OF EXCESSIVE LGTH  46320000
         BL    CMOP2                                                    46340000
         LA    3,126                                                    46360000
         LA    2,124(2)                                                 46380000
         MVC   1(2,2),QZCREOB      MAKE SURE TRUNCATED MESSAGE ENDS     46400000
*                                  WITH CR AND EOB                      46420000
CMOP2    STH   3,0(6)                                                   46440000
         SR    6,MR                MAKE R6 M-RELATIVE -- WE MAY         46460000
*                                  QUANTUM END                          46480000
         CLI   SCNO,2              IS THIS A BROADCAST --               46500000
         BE    CMPA                YES, )PA                             46520000
         BH    CMHI                YES,)HI OR )HIPA                     46540000
CMOPC    TCOM  MSG,M(6)                                                 46560000
         L     4,MPTBASE           IF THE MESSAGE WAS REJECTED,         46580000
         ATT   OFF=CMOP3,MPTBASE=(4) ATTN MEANS THE MSG WAS             46600000
         TYO   CMSREJ              NEVER SENT.  TELL THE SENDER SO.     46620000
         B     BEGST2                                                   46640000
CMOP3    TYO   CMOKMSG             SEND 'SENT' MESSAGE                  46660000
         TM    IOB2-PERTERM(4),RECMM IF A PERMANENTLY-RECEIVING TERM    46680000
         BO    BEGST2              SENT THE MESSAGE, WE'RE DONE.        46700000
CMOP4    CLI   SCNO,0              NOW SUSPEND FOR REPLY IF THAT WAS    46720000
         BZ    BEGST2                                                   46740000
         TCOM  SUSPEND             REQUESTED                            46760000
         B     BEGST2                                                   46780000
CMOKMSG  DC    AL1(0,5,ZS,ZE,ZN,ZT,ZCR,ZEOB)     'SENT'                 46800000
QZCREOB  EQU   *-2                                                      46820000
CMSREJ   DC    H'13'               'MESSAGE LOST'                       46840000
         DC    AL1(ZM,ZE,ZS,ZS,ZA,ZG,ZE,ZBLANK,ZL,ZO,ZS,ZT,ZCR,ZEOB)    46860000
PATXT    DC    AL1(ZP,ZA,ZSHRIEK)                'PA:'                  46880000
CMHI     LA    1,M(6)              MOVE IN OPR                          46900000
         MVC   2(3,1),SYSCOPR                                           46920000
         TCOM  HI,M(6)                                                  46940000
         CLI   SCNO,3              CHECK FOR COMBINED HI AND PA         46960000
         BH    BEGST2              HI WITHOUT PA                        46980000
CMPA     LA    1,M(6)              MOVE IN PA SHRIEK                    47000000
         MVC   2(3,1),PATXT                                             47020000
         TCOM  PA,M(6)             YES.                                 47040000
         B     BEGST2                                                   47060000
*                                                                       47080000
*        )PORTS -- LIST PORTS IN USE AND USER CODES                     47100000
CMPORT   L     3,=A(SUPPARS)       INIT TO LOOP THRU PERTERMS      2230 47120000
         LM    6,8,PTBXLE-SUPPARD(3)                               2230 47140000
         AR    8,6                 IGNORE COPY-SOURCE TERMINAL          47160000
         USING PERTERM,8           PERTERM BEING EXAMINED               47180000
         IC    1,PDSWSN-PDSLIB+OURSDP  AN UNPLEASANT GLITCH FOR NAMES   47200000
         LA    1,PDSWSN-PDSLIB+OURSDP(1) OF UNDER 3 CHARS -- REPLACE    47220000
         MVC   1(2,1),INDENT+1     TRAILING ZEROES BY BLANKS            47240000
CMPORT1  TM    IOB1,NSIGNM         IGNORE UNCONNECTED TERMINALS         47260000
         BO    CMPORT8                                                  47280000
         TM    SCFLG,SCARG2        IS THIS A SELECTIVE LISTING          47300000
         BZ    CMPORT2             NO, LIST EVERYBODY                   47320000
         CLC   PDSWSN+1-PDSLIB+OURSDP(3),PTMANI  DO WE LIST THIS USER   47340000
         BNE   CMPORT8             NO, TRY NEXT ONE                     47360000
CMPORT2  MVI   OBUFPTR+1,7         OUTPUT LINE LENGTH                   47380000
         LA    2,OBUF              TARGET FOR CVTERM                    47400000
         LR    5,8                                                      47420000
         BAL   LKR,CVTERMA         MOVE 3-DIGIT PORT NUMBER TO OBUF     47440000
         MVI   OBUF+3,ZBLANK       THEN BLANK,                          47460000
         MVC   OBUF+4(3),PTMANI    THEN USER INITIALS                   47480000
         ICALL LOUT                OUTPUT THIS LINE                     47500000
CMPORT8  BXLE  8,6,CMPORT1                                              47520000
         MVI   OBUFPTR+1,0         RESET BUFFER POINTER                 47540000
         B     BEGST2                                                   47560000
         DROP  8                                                        47580000
*                                                                       47600000
*        )WSID -- WORK SPACE IDENTIFICATION                             47620000
CMWSID   TM    SCFLG,SCARG2        IF HE WANTS TO CHANGE WSID           47640000
         BZ    CMWS5               TYPE 'WAS '                          47660000
         EX    0,CMPRTWAS                                               47680000
CMWS5    MVC   PDSLIB-PDSLIB+OURSDP+20(16),PDSLIB-PDSLIB+OURSDP         47700000
         LA    1,WFLLIB            PRINT WS IDENTIFICATION              47720000
         ICALL PRWSNAME                                                 47740000
         TM    SCFLG,SCARG2        TEST IF WSID IS TO BE CHANGED        47760000
         BZ    BEGST2              NO, RETURN                           47780000
         MVC   WFLLIB(16),PDSLIB-PDSLIB+OURSDP+20  MOVE IN WSID         47800000
         B     BEGST2                                                   47820000
         SPACE 2                                                        47840000
*        )ORIGIN -- SET WORKSPACE ORIGIN                                47860000
CMORG    CL    1,QF2                                                    47880000
         BCR   11,LKR  BNL         ALLOW ONLY 0 AND 1                   47900000
         L     0,IORIGIN                                                47920000
         ST    1,IORIGIN                                                47940000
         B     CMPRTWAS                                                 47960000
         SPACE 2                                                        47980000
*        )WIDTH -- SET WIDTH OF PRINT LINE                              48000000
CMWIDT   CL    1,QF130             SET WIDTH OF PRINT LINE              48020000
         BCR   2,LKR   BH          NO GREATER THAN 130                  48040000
         CLI   PDSLIB-PDSLIB+3+OURSDP,30                                48060000
         BCR   4,LKR   BL          AND NO LESS THAN 30 (TROUBLE WITH    48080000
*                                  DISPLAY OF FLOATING PT NUMBERS)      48100000
         LH    0,OBUFLIM                                                48120000
         STH   1,OBUFLIM                                                48140000
         B     CMPRTWAS                                                 48160000
         SPACE 2                                                        48180000
*        )DIGITS -- SET NUMBER OF SIGNIF DIGITS                         48200000
CMDIGI   CH    1,QH16              NO GREATER THAN 16                   48220000
         BCR   2,LKR   BH                                               48240000
         LTR   1,1                                                      48260000
         BCR   13,LKR  BNP         MUST ALSO BE GREATER THAN 1          48280000
         L     0,OSIGDIG                                                48300000
         ST    1,OSIGDIG                                                48320000
         B     CMPRTWAS                                                 48340000
*                                                                       48360000
*        )SYMBOLS -- SET SYMBOL TABLE SIZE                              48380000
CMSYMB   C     1,QF26              MUST BE GREATER THAN 20              48400000
         BCR   4,LKR   BL                                               48420000
         LM    3,4,QR13STK ,QSYMBOT POINTERS TO ENDS OF SYMBOL TABLE    48440000
         L     2,SVI               WORKSPACE MUST BE REALLY CLEAR       48460000
         LA    0,STPARAM+8(2)      WHICH MEANS SVI AT HIGHEST POSITION  48480000
SVSBDIF  EQU   *-2                                                      48500000
         LR    5,4                 NEEDED FOR LATER CLEARING            48520000
         SR    0,4                                                      48540000
         BCR   7,LKR   BNZ         AND ALSO S.T. EMPTY (CHECKED LATER)  48560000
         D     0,QFM21             DESIRED NO. OF SYMBOLS, PLUS         48580000
         BCTR  1,0                                                      48600000
         MH    1,QH168             ROUNDING UP TO HASHING INTERVAL,     48620000
         LA    2,8                                                      48640000
         AR    1,2                 LESS 1 TO MAKE TABLE LENGTH RELA-    48660000
         AR    1,3                 TIVELY PRIME TO HASHING INTERVAL.    48680000
         C     1,MX                CHECK FOR EXCESSIVELY LARGE TABLE    48700000
         BCR   4,LKR               NOTE BARE POSSIBILITY OF SVI LSS MX  48720000
*                                  AND MX LSS SYMBOT HERE.  WE'LL LET   48740000
*                                  APLSUP FORCE A LOAD-EMPTY.           48760000
         LCR   0,4                 GET OLD CAPACITY OF TABLE            48780000
         AR    0,3                 TO BE PRINTED                        48800000
         SRL   0,3                 ASSURE EMPTY SYMBOL TABLE, SINCE     48820000
         AR    3,MR                CHANGING SIZE CHANGES THE HASH.      48840000
         AR    4,MR                                                     48860000
         BCTR  3,0                                                      48880000
CMSYMB1  OC    0(8,4),0(4)         ZERO TEST                            48900000
         BCR   7,LKR   BNE                                              48920000
         BXLE  4,2,CMSYMB1                                              48940000
         ST    1,QSYMBOT                                                48960000
         SH    1,SVSBDIF           ADJUST SVI AND PARREL                48980000
         LA    2,4(1)                                                   49000000
         STM   1,2,SVI ,PARREL                                          49020000
         ST    1,SVIT                                                   49040000
         LA    3,M(2)              ABSOLUTE NEW PARREL                  49060000
         SR    2,2                                                      49080000
         LA    4,4                 CLEAR SPACE BETWEEN NEW AND OLD      49100000
CMSYMB2  ST    2,M(1)              SYMBOT (AND STACK)                   49120000
         BXLE  1,4,CMSYMB2         IF REDUCING TABLE SIZE, THIS IS      49140000
         MVI   STFLAGS(3),STIMBIT  SUPERFLUOUS                          49160000
*                                                                       49180000
CMPRTWAS MVC   OBUFPTR+1(5),CMWASMSG   OUTPUT 'WAS NNN'                 49200000
         ICALL PRNUM                                                    49220000
*                                                                       49240000
*              ENTRY TO PRINT LINE, IF ANY, AND RESUME NORMAL OPERATION 49260000
CMEND    ICALL LOUTI               FORCE OUT PRINT LINE                 49280000
CMEND2   BAL   8,RELPNS            RELOCATE ANY PRINT NAMES COLLECTED   49300000
         CLI   FDTOG,0                                                  49320000
         BE    TYPIN2              CLEAR SWITCHES IF NOT IN FN DEFN     49340000
         B     BEGST2                                                   49360000
*        )SI -- )SIV                                                    49380000
*        DISPLAY FUNCTION NAMES, LINE NUMBERS, AND SUSPENSION (IMM-EX)  49400000
*        FOR ALL FUNCTIONS CURRENTLY ON THE EXECUTION STACK.            49420000
*                                                                       49440000
CMSI     LA    3,PARREL-M-STFREG                                        49460000
CMDELT6  L     3,STFREG(3,MR)                                           49480000
         L     1,STFREG(3,MR)                                           49500000
         BXLE  1,1,BEGST2                                               49520000
         LA    4,M(3)                                                   49540000
         LA    1,ZQUAD             PRINT A QUAD                         49560000
         TM    STFLAGS(4),STQBIT   IS THIS QUAD INPUT MODE              49580000
         BO    CMDELT2                                                  49600000
         LR    1,3                 NO, PRINT FN AND LINE NO OR BLANKS.  49620000
         ICALL PLINE                                                    49640000
         LA    4,M(3)              WERE WE IN IMMEDIATE-EXECUTION ON    49660000
         TM    STFLAGS(4),STIMBIT  THIS LEVEL --                        49680000
         BZ    CMDELT4             NO                                   49700000
         LA    1,ZSTAR             YES. PRINT '*' FOR SUSPENSION.       49720000
CMDELT2  ICALL TOPRINT                                                  49740000
CMDELT4  CLI   SCNO,0              IF )SI, WE DON'T LIST VARIABLE NAMES 49760000
         BZ    CMDELT3                                                  49780000
         BAL   2,CMINDENT          INDENT FOR FIRST OBJECT              49800000
         LA    4,M+8(3)                                                 49820000
CMDELT5  CLI   STSHADOW(4),SHADOW+X'80' DETERMINE IF ALL VARS HAVE BEEN 49840000
         BNE   CMDELT3             LISTED. IF SO SKIP AHEAD             49860000
         L     6,STSHADOW(4)                                            49880000
         SR    4,MR                M-RELATIVE REG 4                     49900000
         N     6,QF24BITS          KNOCK OFF HIGH ORDER GARBAGE         49920000
         BZ    CMDELT8             IF LOCAL OMITTED, NOTHING TO LIST    49940000
         CLI   OBUFPTR+1,0         INDENT IF ON A NEW LINE              49960000
         BNE   *+8                                                      49980000
         BAL   2,CMINDENT                                               50000000
         BAL   2,PRDENT            PRINT & INDENT                       50020000
CMDELT8  LA    4,M+8(4)                                                 50040000
         B     CMDELT5             GO TRY NEXT ONE                      50060000
CMDELT3  ICALL LOUTI               OUTPUT LINE                          50080000
         B     CMDELT6                                                  50100000
         SPACE 2                                                        50120000
*        )FNS -- LIST FUNCTIONS                                         50140000
CMFNS    BAL   8,CMDPY             SET UP TO PRINT ALPHABETICAL LIST OF 50160000
*                                  DEFINED FUNCTIONS                    50180000
         CLI   DTEMP,DFN                                                50200000
         BE    4(LKR)                                                   50220000
         CLI   DTEMP,DFN0                                               50240000
         BE    4(LKR)                                                   50260000
         BR    LKR                 RETURN TO 0(LKR) ON NO               50280000
*                                                                       50300000
*        )VARS -- LIST VARIABLES                                        50320000
CMVARS   BAL   8,CMDPY             SETUP FOR LIST OF VARIABLES          50340000
*                                                                       50360000
         CLI   DTEMP,VARB                                               50380000
         BCR   7,LKR                                                    50400000
         N     0,QF24BITS                                               50420000
         BCR   8,LKR                                                    50440000
         B     4(LKR)                                                   50460000
*                                                                       50480000
*        )GRPS -- LIST GROUPS                                           50500000
CMGRPS   BAL   8,CMDPY             SETUP FOR LIST OF GROUP NAMES        50520000
*                                                                       50540000
         CLI   DTEMP,GROUP                                              50560000
         BE    4(LKR)                                                   50580000
         BR    LKR                                                      50600000
*                                                                       50620000
         AGO   .APL2                                                    50640000
.APL2    ANOP                                                           50660000
*                                                                       50680000
CMDPY    L     6,SVI               ALPHABETIC DISPLAY ROUTINE           50700000
         ST    8,NTEMP             SAVE RETURN REG.                3036 50720000
         MVI   PDSWSN-PDSLIB+OURSDP,3   USE ONLY FIRST LETTER GIVEN     50740000
         L     1,PDSWSN-PDSLIB+OURSDP  MAKE IT SLIGHTLY SMALLER         50760000
         BCTR  1,0                                                      50780000
         CLI   PDSWSN+1-PDSLIB+OURSDP,0                                 50800000
         BH    *+8                                                      50820000
         L     1,QLOWNM            START SEARCH WITH VERY LOW PRINT     50840000
         ST    1,M(6)              NAME AS 'LAST NAME PRINTED'.         50860000
         A     6,QFM4              POINTERS ARE ALL LOW BY 4            50880000
         L     3,QSYMBOT           START LOOP AT BOTTOM OF SYMBOL TABLE 50900000
         LA    4,8                                                      50920000
         L     5,QR13STK           END IT AT TOP                        50940000
         BCTR  5,0                 FIX BXLE END TEST                    50960000
*              IN THE FOLLOWING,                                        50980000
*              R1 = RUNNING INDEX TO PNAME BEING EXAMINED               51000000
*              R2 = SECOND ARG ADDRESS FOR SYMBOL COMPARE               51020000
*              R3 = LOWEST ADDR WHICH NEED BE INSPECTED                 51040000
*              R4 = 8 = SYMBOL TABLE ENTRY LENGTH                       51060000
*              R5 = LOOP LIMIT (TOP OF TABLE)                           51080000
*              R6 = ADDR OF CURRENT CANDIDATE FOR PRINTING              51100000
*              R7 = ADDR OF LAST SYMBOL PRINTED                         51120000
*              R8 = ADDRESS OF 'IS VARB', 'IS DFN', OR 'IS GRP' TESTER  51140000
*                                                                       51160000
CMDP4    LR    1,3                 CAN LOWER LIMIT OF SEARCH BE UPPED - 51180000
         BAL   LKR,CMDIF                                                51200000
         B     CMDP5               YES.  SYMBOL NOT A VARB (DFN).       51220000
CMDP3    LR    1,3                 WE MUST LOOK AT SYMBOL               51240000
         LR    2,6                 IF IT'S LOWER THAN SYMBOL PREVIOUSLY 51260000
         BAL   LKR,SCOMP           PRINTED, WE CAN IGNORE IT.           51280000
         B     CMDP5               IT'S ALREADY BEEN PRINTED.           51300000
         LR    7,6                 END OF LOWER LIMIT ADJUSTMENT        51320000
         LR    6,3                 SET NEW 'LAST SYMBOL PRINTED' AND    51340000
         LR    1,3                 RUNNING INDEX.                       51360000
CMDP7    BXH   1,4,CMDP6           HAVE WE SWEPT ENTIRE TABLE --        51380000
         BAL   LKR,CMDIF           NO. SKIP CURRENT SYMBOL              51400000
         B     CMDP7               IF IT'S NOT A VARB (DFN).            51420000
         LR    2,7                 IT IS.  MATCH IT AGAINST LAST SYMBOL 51440000
         BAL   LKR,SCOMP                                                51460000
         B     CMDP7               PRINTED                              51480000
         LR    2,6                 IT'S HIGH, SO IT HASN'T BEEN PRINTED 51500000
         BAL   LKR,SCOMP           YET.  MATCH IT AGAINST CURRENT       51520000
         LR    6,1                 CANDIDATE FOR PRINTING.              51540000
         NOPR  0                   SKIP THE LR IF IT'S NOT LOWER.       51560000
         B     CMDP7               BACK FOR NEXT SYMBOL COMPARISON      51580000
CMDP6    LA    2,CMDP3             FAKE CALL & RETURN FROM PRDENT       51600000
*                                                                       51620000
*                                  PRINT NAME FROM R6 WITH FOLLOWING    51640000
*                                    TAB.  R2 = LINK REG                51660000
*                                                                       51680000
PRDENT   LA    1,M+4(6)            MAKE R1 = M-REL ADDR OF PRINT NAME   51700000
         CLI   0(1),3                                                   51720000
         BNH   CMDP8                                                    51740000
         L     1,M+4(6)            ADDRESS FOR LONG PRINT NAME          51760000
         LA    1,M+8(1)                                                 51780000
CMDP8    ICALL SQUIRT                                                   51800000
         QUEND                                                          51820000
CMINDENT LA    1,ZBLANK            IMITATE TAB STOPS                    51840000
         ICALL TOPRINT                                                  51860000
         LH    1,OBUFPTR           TO SPACE NAMES OUT IN REASONABLE     51880000
         N     1,QF7                                                    51900000
         BNZ   CMINDENT            COLUMNS.                             51920000
         ATT   ON=CMDP9,RESET=NO   BACK FOR MORE IF NO ATTENTION        51940000
         BR    2                                                        51960000
CMDP5    BXLE  3,4,CMDP4           BUMP THE LOWER LIMIT OF SEARCH       51980000
CMDP9    ICALL LOUTI               FORCE OUT PRINT LINE                 52000000
         B     BEGST2              PAST TOP OF TABLE -- ALL DONE.       52020000
CMDIF    L     0,M(1)              IF SYMBOL TABLE ENTRY IS        3036 52040000
         LTR   0,0                   COMPLETELY EMPTY...           3036 52060000
         BCR   8,LKR  BZ           THEN RETURN TO CALLER           3036 52080000
         ST    0,DTEMP             STORE RESULT IN CASE FN OR GRP  3036 52100000
         C     0,QFDFN             SEARCH STACK ONLY IF A VAR      3036 52120000
         BCR   11,8  BNL           BR IF NOT A VAR                 3036 52140000
         STM   LKR,3,SKBTEMP       SAVE REGS THRU TUSAG            3036 52160000
         LR    3,1                 POINTS TO S.T. ENTRY            3036 52180000
         BAL   LKR,TUSAG           FIND GLOBAL DEFN OF SYMBOL      3036 52200000
         QUEND                                                     3036 52220000
         L     0,M(3)              GET SYMBOL-TYPE CODE            3036 52240000
         ST    0,DTEMP                                             3036 52260000
         L     LKR,SKBTEMP         RESTORE CALLER'S REGS. KEEP     3036 52280000
         LM    1,3,SKBTEMP+8        R0 AS-IS FOR )VARS CHECK.      3036 52300000
         L     8,NTEMP             PICK UP RETURN REG              3036 52320000
         BR    8                                                        52340000
*                                                                       52360000
*                                                                       52380000
*              THE SYMBOL COMPARISON ROUTINE                            52400000
*              COMPARES A AND B UP TO THE LENGTH OF THE SHORTER         52420000
*              COMPARES LENGTHS IF ALPHAS ARE EQUAL                     52440000
*              ON ENTRY, R1 = A ADDRESS                                 52460000
*                        R2 = B ADDRESS                                 52480000
*              RETURNS TO 0 ON A LEQ B, 4 ON A GTR B                    52500000
SCOMP    STM   1,4,ILN             ILN IS CONVENIENT AND UNUSED         52520000
         BAL   4,SCSB              FIND REAL PRINT NAME                 52540000
         LR    3,1                                                      52560000
         LR    1,2                 FOR BOTH ARGUMENTS                   52580000
         BAL   4,SCSB                                                   52600000
         IC    2,4(3)              GET LENGTH OF A                      52620000
SC3      CLC   4(1,3),4(1)         IS IT SHORTER THAN LENGTH OF B --    52640000
         BL    SC1                 YES                                  52660000
         IC    2,4(1)              NO.  GET LENGTH OF B INSTEAD.        52680000
SC1      BCTR  2,0                 MAKE IT AN SS COUNT                  52700000
         EX    2,SCLC              COMPARE ALPHABETICS                  52720000
         BNE   SC2                 NOT EQUAL.  RETURN IMMEDIATELY.      52740000
         EX    0,SC3               EQUAL.. COMPARE LENGTHS              52760000
SC2      LM    1,4,ILN             RELOAD SAVED REGISTERS               52780000
         BCR   13,LKR              BRANCH NOT HIGH TO 0                 52800000
         B     4(LKR)              BRANCH HIGH TO 4                     52820000
*                                                                       52840000
SCSB     AR    1,MR                FIND PRINT NAME GIVEN SYMBOL ADDRESS 52860000
         CLI   4(1),3              IS IT A SHORT PRINT NAME --          52880000
         BCR   13,4                YES.  NO WORK.                       52900000
         L     1,4(1)              NO.  FIND M-ENTRY OF PRINT NAME      52920000
         LA    1,M+4(1)            OFFSET R1 BY 4 FROM PRINT NAME       52960000
         BR    4                                                        52980000
SCLC     CLC   5(0,3),5(1)                                              53000000
         SPACE 2                                                        53020000
*        )GRP -- LIST NAMES IN A GROUP                                  53040000
CMGRP    BAL   8,SCANID            PICK UP GROUP NAME                   53060000
         B     CMDERR              ERROR IF NONE PROVIDED               53080000
         CLI   TUSR,4              IGNORE COMMAND IF NOT A GROUP NAME   53100000
         BNE   CMEND                                                    53120000
         L     5,M(3)              LOCATE GROUP DEFINITION              53140000
         LH    7,MLSCT(5)          PICK UP NUMBER OF MEMBERS            53180000
CMGRPA   L     6,MLSORG(5)         PICK UP S.T. POINTER FOR A MEMBER    53200000
         BAL   2,PRDENT            PRINT NAME & TAB                     53220000
         LA    5,4(5)              ADVANCE TO NEXT MEMBER               53240000
         BCT   7,CMGRPA                                                 53260000
         B     CMEND               EXIT                                 53280000
         SPACE 2                                                        53300000
*        )ERASE                                                         53320000
*              ERASE ZERO OR MORE GLOBAL OBJECTS (VARS, FNS, GROUPS)    53340000
*              ERASING A GROUP UNDEFINES ITS MEMBERS, TO ONE LEVEL.     53360000
CMERA    BAL   8,SCANID            LOOK AT NEXT ARG OF COMMAND          53380000
         B     CMERZ               DONE.                                53400000
         SR    6,MR                RELATIVIZE OVER POSSIBLE OUTPUT      53420000
         ST    6,SRCHRET+4         OPERATION                            53440000
         L     5,M(3)              SYMBOL TABLE ENTRY OF GLOBAL         53460000
         LR    1,5                                                      53480000
         BAL   8,CMERASB           ERASE IT IF POSSIBLE                 53500000
         CLI   TUSR,4              IF IT'S A GROUP,                     53520000
         BNE   CMERA1                                                   53540000
         LH    7,MLSCT(5)          NO. OF MEMBERS                       53580000
CMERA2   L     3,MLSORG(5)         NEXT GROUP MEMBER                    53600000
         BAL   LKR,TUSAG           FIND GLOBAL SIGNIFICANCE             53620000
         L     1,M(3)              R1 = SYMBOL TABLE OR STACK ENTRY     53640000
         BAL   8,CMERASB           AND ERASE                            53660000
         LA    5,4(5)              ADVANCE TO NEXT MEMBER               53680000
         BCT   7,CMERA2                                                 53700000
CMERA1   L     6,SRCHRET+4         INPUT STRING POINTER, SAVED OVER ALL 53720000
         AR    6,MR                PREVIOUS GOINGS-ON.                  53740000
         B     CMERA               DONE WITH GROUP.  BACK TO INPUT CMD  53760000
CMERZ    CLI   0(6),ZCR            MUST BE END OF LINE                  53780000
         BNE   CMDERR                                                   53800000
         B     CMEND                                                    53820000
*                                                                       53840000
*              ERASE SUBROUTINE                                         53860000
*              ON ENTRY,                                                53880000
*                  R1 = SYMBOL TABLE (OR STACK) ENTRY OF OBJECT         53900000
*                  R2 = POINTER TO SYMBOL TABLE ENTRY (FOR PRINTNAME)   53920000
*                  R3 = POINTER TO SYMBOL TABLE OR STACK ENTRY OF OBJEC 53940000
*                  R8 = LINK                                            53960000
CMERASB  CL    3,PINAB             SPECIAL TREATMENT FOR FUNCTION       53980000
*                                  CURRENTLY BEING DEFINED.             54000000
         BNE   DEL30               ERASE ORDINARY OBJECT                54020000
         STM   5,8,ACCTG           CONVENIENT HIDEY HOLE                54040000
         BAL   LKR,ERFID                                                54060000
         LM    5,8,ACCTG           FOR R5 AND R8                        54080000
         B     DEL30B                                                   54100000
*                                                                       54120000
*        )GROUP -- DEFINE A GROUP                                       54140000
CMGROU   BAL   8,SCANID            PICK UP GROUP NAME                   54160000
         B     CMDERR              ERROR IF OMITTED                     54180000
         TM    COPTOG,COPIBIT      ARE WE A COPY SINK              5992 54200000
         BO    CMGROU2             BR IF COPY SINK                 5992 54220000
         TM    TUSR,X'03'          IF DFN OR VAR, ERROR                 54240000
         BNZ   CMGRUSED            WE ASSUME TUSR IN 0 - 7              54260000
CMGROU2  EQU   *                                                   5992 54280000
         MVC   NTEMP(1),TUSR       SAVE TUSR                            54300000
         STM   2,3,DTEMP           SAVE POINTERS FOR GROUP NAME         54320000
         L     5,MX                                                     54340000
         SR    7,7                 INITIALIZE NUMBER OF NAMES IN        54360000
         STH   7,MLSCT(5)            GROUP TO ZERO                      54380000
         LA    7,MLSORG-M          INITIALIZE AMOUNT OF OVERHEAD        54400000
         STH   7,MLSOS(5)                                               54420000
         AR    7,5                                                      54440000
         ST    7,TOCPTR            POINT TO TOP OF LIST                 54460000
         BAL   LKR,FREECH          MAKE SURE WE HAVE ROOM               54480000
CMGROU1  BAL   8,SCANID            PICK UP NEXT NAME                    54500000
         B     CMGREND             IF OMITTED, GO CLEAN-UP              54520000
         C     2,DTEMP             IF HE WANTS OLD DEFN, GO COPY IT IN  54540000
         BE    CMGRCOPY                                                 54560000
         O     2,QFMSMALL          SET HIGH BIT TO INDICATE S.T. PNTR   54580000
         BAL   8,CMGRSCAN          ADD THIS NAME TO LIST IF NOT         54600000
         B     CMGROU1               ALREADY THERE.                     54620000
*        COPY IN THE OLD DEFN OF NAMED GROUP                            54640000
*              CAUTION... WE ASSUME THAT WE NEVER WILL HAVE A NULL      54660000
*              GROUP, OR A GROUP THAT CONTAINS ITSELF.                  54680000
CMGRCOPY CLI   NTEMP,0             IF GROUP WAS NOT DEFINED PREVIOUSLY  54700000
         BE    CMGROU1               IGNORE THIS NAME                   54720000
         L     3,DTEMP+4           PICK UP OLD DEFN ADDRESS             54740000
         L     3,M(3)                                                   54760000
         LH    4,MLSCT(3)          PICK UP NUMBER OF NAMES IN SOURCE    54800000
         LA    3,MLSORG-M(3)       IGNORE OVERHEAD                      54820000
CMGRCPY1 L     2,M(3)              PICK UP NEXT NAME                    54840000
         BAL   8,CMGRSCAN          PUT INTO GROUP IF NEEDED             54860000
         LA    3,4(3)              LOOP THRU LIST UNTIL DONE            54880000
         BCT   4,CMGRCPY1                                               54900000
         B     CMGROU1                                                  54920000
*        SCAN GROUP DEFN & ADD NAME IF NOT ALREADY THERE.               54940000
*              R2=S.T. ADDR   R3 & R4 PRESERVED   R8=LINK               54960000
CMGRSCAN L     5,MX                                                     54980000
         LH    7,MLSCT(5)          PICK UP CURRENT LIST ENTRY COUNT     55000000
         LTR   1,7                 IF NULL, WE SURE WON'T FIND IT       55020000
         BZ    CMGRSCN2                                                 55040000
         LA    5,MLSORG-M(5)       IGNORE OVERHEAD                      55060000
CMGRSCN1 C     2,M(5)              DOES THIS ENTRY MATCH                55080000
         BCR   8,8                 YES, WE DON'T WANT DUPLICATES        55100000
         LA    5,4(5)              TRY NEXT ENTRY, UNTIL DONE           55120000
         BCT   1,CMGRSCN1                                               55140000
CMGRSCN2 L     5,TOCPTR            SAVE S.T. POINTER FOR NEW NAME       55160000
         ST    2,M(5)                                                   55180000
         LA    5,4(5)              INCREMENT TOP OF LIST BY 4           55200000
         ST    5,TOCPTR                                                 55220000
         LA    7,1(7)              INCREMENT NUMBER OF ENTRIES BY 1     55240000
         L     5,MX                                                     55260000
         STH   7,MLSCT(5)                                               55280000
         BAL   LKR,FREECH          RESERVE MORE ROOM                    55300000
         BR    8                   RETURN                               55320000
CMGREND  DS    0H                                                       55340000
*        IF )GROUP CMD SEEN DURING )PCOPY, PROTECT OLD DEFN.       5992 55360000
*        (WE WAITED UNTIL NOW FOR THIS CHECK BECAUSE WE WANT TO GET5992 55380000
*        ALL OF THE INPUT FROM COPY SOURCE.)                       5992 55400000
         TM    COPTOG,COPPBIT      WAS )GROUP SEEN DURING )PCOPY   5992 55420000
         BZ    CMGREND1            BR IF NOT A )PCOPY              5992 55440000
         CLI   NTEMP,0             WAS GROUP NAME PREV DEFINED     5992 55460000
         BNE   CMEND               BR IF PREV DEFINED              5992 55480000
CMGREND1 EQU   *                                                   5992 55500000
         L     3,DTEMP+4           DISPERSE THE OLD DEFINITION          55520000
         L     1,M(3)              MARK THE OLD DEFN (IF ANY) GARBAGE   55540000
         BAL   8,DEL30             AND CLEAR THE S.T. ENTRY             55560000
         L     7,MX                                                     55580000
         LH    6,MLSCT(7)          IF NEW DEFN IS A NULL GROUP,         55600000
         LTR   6,6                   LEAVE IT UNDEFINED                 55620000
         BZ    CMEND                                                    55640000
         O     7,QGRCODE           POINT S.T. TO DEFN                   55660000
         ST    7,M(3)                                                   55680000
         O     3,QLSTCODE          POINT DEFN TO SYMBOL TABLE           55700000
         N     7,QF24BITS          CLEAN HIGH BYTE OF JUNK              55720000
         ST    3,MHEAD(7)                                               55760000
         SLA   6,2                 CONVERT WORD COUNT TO BYTES          55780000
         LA    6,MLSORG-M(6)       ADD IN OVERHEAD                      55800000
         ST    6,MCOUNT(7)         PUT BYTE COUNT IN M                  55820000
         AR    7,6                                                      55840000
         ST    7,MX                UPDATE MX                            55860000
         B     CMEND               EXIT                                 55880000
CMGRUSED TYO   CMGRNUSD            ERROR, NAME IN USE                   55900000
         B     CMEND                                                    55920000
 TITLE 'S Y S T E M   C O M M A N D S   - -   S P E C I A L   D I S K'  55940000
*                                                                       55960000
OURSDP   EQU   OBUF+16             TYPEIN'S LOCATION FOR SPEC DISK      55980000
*                                  PARAMETERS BEFORE SDREQ TAKES THEM   56000000
         SPACE 3                                                        56020000
*        )CLEAR -- CLEAR WS                                             56040000
CMCLEAR  SR    0,0                 INDICATE DIRECTORY 0                 56060000
CMLEMP   LEMP  ,                   LOAD DIRECTORY                       56080000
         SPACE 2                                                        56100000
*        )DELETE -- DELETE USER FROM SYSTEM                             56120000
CMDELE   L     4,PDSLIB-PDSLIB+OURSDP                                   56140000
         BAL   LKR,SOPSUB          IS HE SIGNED-ON NOW?                 56160000
         B     SOPDUP              YES, SEND 'NUMBER IN USE' MESSAGE    56180000
         B     SPDISK              NO, LET'S GET BUSY DELETING HIM      56200000
         SPACE 2                                                        56220000
*        )SAVE -- SAVE WS -- SPECIAL CHECK FOR MISSING NAME             56240000
CMSAVE   TM    SCFLG,SCARG2        CHECK FOR ELIDED NAME                56260000
         BO    SPDISK                                                   56280000
         TM    SCFLG,SCARG1        LIB NUMBER MUST THEN BE ELIDED TOO   56300000
         BCR   1,LKR   BO                                               56320000
         CLI   PDSPASS-PDSLIB+OURSDP,0 PASSWORD MUST BE ELIDED          56340000
         BCR   7,LKR   BNE                                              56360000
         MVC   PDSLIB-PDSLIB+OURSDP(16),WFLLIB MOVE FILE LABEL INFO     56380000
         MVC   PDSPASS-PDSLIB+OURSDP(8),WFLPASS INTO PARAM AREA         56400000
         B     SPDISK                                                   56420000
         SPACE 2                                                        56440000
*              ENTRY FOR FORCED SIGNOFF                                 56460000
CMFOFF   EX    0,NEWIDZ            NO CHANGE IN SIGNON PASSWORD         56480000
         MVI   SCNO,XXOFF          READ SPDISK OP IS )OFF               56500000
         MVI   NTEMP,0             DROP LINE AFTER SIGNOFF              56520000
         BAL   8,RELPNS            RELOC ANY PNAMES NOW ABOVE SVI  2534 56540000
         SPACE 2                                                        56560000
*        )CONTINUE COMMAND                                              56580000
*                                  MOVE 'CONTINUE' TO WSID              56600000
CMCONT   MVC   PDSWSN-PDSLIB+OURSDP(14),SPDSAVE                         56620000
         MVC   PDSPASS-PDSLIB+OURSDP(8),WFLPASS                         56640000
*                                  IS TO FAKE A )SAVE.                  56660000
         NI    SCFLG,255-SCARG2    'HOLD' DOESN'T REALLY COUNT AS ARG   56680000
         LA    0,FREE-M            NO SAVE AT ALL IF WORKSPACE          56700000
         CL    0,MX                IS EMPTY                             56720000
         BNL   CMOFF                                                    56740000
CMOFFA   L     1,=A(SUPPARS)       GET LIB NO. OF THIS MAN         2230 56760000
         L     1,PTBASE-SUPPARD(1) A(PERTERM) FROM PROTECTED CORE  2230 56780000
         MVC   PDSLIB-PDSLIB+OURSDP(4),PTMAN-PERTERM(1)    THIS MAN'S.  56800000
         CLI   NTEMP,X'00'         CHECK FOR 'HOLD' OMITTED        3033 56820000
         BE    SPDISK              BRANCH IF OMITTED               3033 56840000
         CLC   NTEMP(5),QZHOLD     WAS OPERAND 'HOLD'              3033 56860000
         BNE   CMDERR              ERROR IF NOT 'HOLD'             3033 56880000
         B     SPDISK                                                   56900000
*                                                                       56920000
*              ADD COMMAND HAS FURTHER NUMERIC PARAMETERS               56940000
CMADD    BAL   LKR,ININT           FIND NUMBER FOLLOWING AND SEND IT    56960000
         DC    2Y(CMDERR-TYPTOP)   AS INCREMENTAL WSS FOR THIS USER.    56980000
         STH   3,PDSWSQI-PDSLIB+OURSDP                                  57000000
         BAL   LKR,SKBL            SKIP ANY BLANKS                      57020000
         BAL   LKR,INFLT           BUILD CPU TIME LIMIT                 57040000
         DC    Y(CMDERR-TYPTOP,SPDISK-TYPTOP)                           57060000
         DC    Y(D3000-TYPTOP,D10-TYPTOP)                               57080000
         MVC   PDSCPUL-PDSLIB+OURSDP,DTEMP+6                            57100000
         LTDR  0,0                  0 LIMIT MEANS RESET TO INFIN        57120000
         BNZ   SPDISK                                                   57140000
         MVI   PDSCPUL-PDSLIB+OURSDP,X'80'    MARK FOR APLSUP           57160000
         B     SPDISK                                                   57180000
*                                                                       57200000
CMCOPY   MVC   COPTOG(1),SCNO      COPTOG SHOWS DEGREE OF PROTECTION    57220000
         MVI   PDSOPA-PDSLIB+OURSDP,XXCOPY ONLY CMPS WHERE SCNO NE SDOP 57240000
         BAL   LKR,BLDID                                                57260000
         STC   5,PDSID-PDSLIB+OURSDP                                    57280000
         MVC   PDSID+1-PDSLIB+OURSDP(77),0(7)  MOVE 78 CHARACTERS       57300000
*                                  (LONGEST NAME) INTO THE PARAM BLOCK  57320000
         BAL   LKR,SKBL            OBJECT NAME MUST BE LAST NONBLANK    57340000
         CLI   0(6),ZCR                                                 57360000
         BNE   CMDERR                                                   57380000
*                                                                       57400000
*        SPECIAL DISK OPERATIONS.                                       57420000
SPDISK   SDREQ OURSDP              WE COMMUNICATE WITH APLSUP AND       57440000
*                                  DIRECTORY SEARCH THROUGH OURSDP AND  57460000
*                                  PDSLIB (IN PERTERM)                  57480000
         EJECT                                                          57500000
         ENTRY SDRET                                                    57520000
*        THIS CURIOUS CODE IS NEEDED BECAUSE WHENEVER APLSUP LOADS A    57540000
*        SAVED WORKSPACE (OR CONTINUES EXECUTION WITH A CURRENT WORK-   57560000
*        SPACE WHICH HAS JUST EXECUTED SDREQ), IT JAMS A(SDRET) INTO    57580000
*        THE WORKSPACE'S SAVED PSW.  THIS IS DONE SO THAT BETWEEN THE   57600000
*        TIME THAT A WORKSPACE IS SAVED AND LOADED, IT IS POSSIBLE TO   57620000
*        REASSEMBLE AND RELINK THE INTERPRETER.  AT THE POINT THAT      57640000
*        MACRO SDREQ WAS EXECUTED, THE ONLY PROGRAM- LOCATION-DEPENDENT 57660000
*        VALUES ALIVE ARE THE PROGRAM BASE REGISTERS AND THE SAVED PSW. 57680000
*        THE DISK OP IS IN PDSOP (IN PERTERM.)                          57700000
*        EXCEPTION.. )CONTINUE AND )SAVE USE R13 STORAGE FREELY         57720000
*        BECAUSE WE KNOW THAT WORKSPACE HAS NOT JUST BEEN LOADED.       57740000
*                                                                       57760000
SDRET    BALR  PR,0                REESTABLISH PROGRAM BASE REGISTERS   57780000
         USING *,PR                                                     57800000
         DROP  10                                                       57820000
         DROP  9                                                        57840000
         L     PR,ATYPTOP                                               57860000
         USING TYPTOP,PR                                                57880000
         LA    10,4095(PR)                                              57900000
         USING TYPTOP+4095,10                                           57920000
         LA    9,4095(10)                                               57940000
         USING TYPTOP+2*4095,9                                          57960000
         LA    TLR,(PREPLEND-PREPLOC+7)/8*8(LR)                         57980000
         L     2,PARREL            SET QUAD AND QUAD-PRIME FLAGS        58000000
         AR    2,MR                                                     58020000
         MVC   QUADTOG(1),STFLAGS(2)                                    58040000
         MVI   INTOG,0             CLEAR INLINE TOGGLES                 58060000
         L     4,=A(SUPPARS)       A(PERTERM) FROM PROTECTED CORE  2230 58080000
         L     4,PTBASE-SUPPARD(4)                                 2230 58100000
         USING PERTERM,4           BASE REGISTER TO PERTERM BLOCK       58120000
*                                  'COPY WRITE' MODE MEANS WE HAVE BEEN 58140000
         TM    IOB1,COPYWM         RESURRECTED FROM THE LIBRARY TO      58160000
         BO    COPST               SERVE AS A COPY SOURCE.              58180000
*                                                                       58200000
* * * * *THE ORDER OF THESE TESTS IS CRITICAL.  COPY SOURCE HAS A       58220000
*        CUT-DOWN PERTERM WHICH CONTAINS NO SDOP.  COPY TEST MUST       58240000
*        THEREFORE BE PERFORMED FIRST.                                  58260000
*                                                                       58280000
         TM    IOB1,COPYRM                                              58300000
         BO    BEGST2              'COPY READ' MODE MEANS WE'RE A SINK. 58320000
         CLI   PDSOP,XXOFF         SPECIAL ACTION FOR )OFF OR )CONTINUE 58340000
         BE    CMOFF1                                                   58360000
*                                  IF WE HAVE JUST RETURNED FROM AN UN- 58380000
         TM    IOB1,TRREJ          SUCESSFUL )LOAD, )SAVE, OR )DROP     58400000
         BO    SPD7                AVOID PRINTING ANY MESSAGE           58420000
         CLI   PDSOP,XXLOAD        PRINT MSG FOR )LOAD, )SAVE, )DROP.   58440000
         BH    BEGST2                                                   58460000
         BL    SPD3                AS ('SAVED') DATE TIME (WSID)        58480000
         MVC   OBUFPTR+1(6),SAVMSG MOVE IN 'SAVED ' MESSAGE             58500000
SPD3     L     3,WFLTIME           )LOAD AND )SAVE  PRINT TIMESTAMP     58520000
         LA    1,WFLDATE           FROM WS FILE LABEL                   58540000
         CLI   PDSOP,XXDROP                                             58560000
         BNE   SPD4                )DROP, HOWEVER,                      58580000
         ICALL GETIME              PRINTS CURRENT TIME AND DATE NO      58600000
         LR    3,1                                                      58620000
         L     1,=A(ZSYMDATE)      MATTER WHAT                          58640000
SPD4     BAL   8,PRINTIME                                               58660000
         BAL   8,PRINDATE                                               58680000
         L     4,=A(SUPPARS)       A(PERTERM) FROM PROTECTED CORE  2230 58700000
         L     4,PTBASE-SUPPARD(4)                                 2230 58720000
         CLI   PDSOP,XXSAVE        FORGET ABOUT NAME IF NOT )SAVE       58740000
         BNE   SPD6                                                     58760000
         TM    SCFLG,SCARG2        PRINT NAME IF NAMELESS )SAVE         58780000
         BO    SPD6                 OR )CONTINUE                        58800000
         LA    1,WFLLIB                                                 58820000
         ICALL PRWSNAME                                                 58840000
SPD6     ICALL LOUTI                                                    58860000
         CLI   PDSOP,XXSAVE                                             58880000
         BL    BEGST2              RETURN NORMALLY FOR )DROP, OR        58900000
         BH    TYPIN4              TO INITIALIZATION FOR )LOAD          58920000
SPD7     CLI   SCNO,XXOFF          FOR )SAVE, CHECK FOR )SAVE FAKED BY  58940000
         BNE   BEGST2              )CONTINUE OR FORCED SIGNOFF.         58960000
         SPACE                                                          58980000
         DROP  4                                                        59000000
         SPACE 2                                                        59020000
         EX    0,SYSC12            CLEAR SPECIAL DISK PARAM BLOCK       59040000
         CLI   WFLPASS,0           NO AUTO-LOAD IF CONTINUE LOCKED      59060000
         BNE   CMOFF                                                    59080000
         MVI   PDSWSQI-PDSLIB+OURSDP,X'80'   SET AUTO LOAD FLAG         59100000
*              REENTRY FOR NON-SAVING )CONTINUE OR FORCED SIGNOFF       59120000
CMOFF    MVC   PDSPASS-PDSLIB+OURSDP(8),NEWID MOVE IN SIGNON PASSWORD   59140000
         MVI   PDSOPA-PDSLIB+OURSDP,XXOFF  AND SPDISK OP FOR )OFF       59160000
         B     CMOFFA                                                   59180000
         SPACE 2                                                        59200000
CMOFF1   MVC   ACCTG(16),OURSDP    SIGN-OFF ACCOUNTING.                 59220000
         LA    2,OBUF                                                   59240000
         BAL   LKR,CVTERM          CONVERT THE TERMINAL NUMBER          59260000
         MVI   OBUFPTR+1,3                                              59280000
         ICALL GETIME                                                   59300000
         LR    3,1                 INSERT TIME OF DAY, DATE             59320000
         BAL   8,PRINTIME                                               59340000
         BAL   8,PRINTDAT                                               59360000
         L     4,MPTBASE                                                59380000
         USING PERTERM,4                                                59400000
         MVC   OBUF+23(3),PTMANI   MOVE IN USER CODE                    59420000
         MVI   OBUFPTR+1,26        MAKE A GUESS AT THE LENGTH           59440000
         ICALL LOUT                LOUT TELLS US HOW LONG THE LINE      59460000
         MVC   OBUFPTR(2),LLLO       REALLY IS.                         59480000
         TCOM  LOG,OBUFPTR         TELL OPERATOR ABOUT SIGN OFF         59500000
         DROP  4                                                        59520000
         MVC   OBUFPTR(32),ACTMS1  SET UP TO PRINT                      59540000
*              CONNECTED HH.MM.SS ,  TO DATE  HH.MM.SS                  59560000
*              CPU TIME  HH.MM.SS ,  TO DATE  HH.MM.SS                  59580000
         L     6,QFM4              INDEX TO ACCTG                       59600000
ACCL     L     3,ACCTG+12(6)       PICK UP TODAY'S TIME                 59620000
         BAL   8,PRINTIME          CONVERT IT                           59640000
         LA    7,30                SET OUTPUT PTR FOR CUMULATIVE TIME   59660000
         STH   7,OBUFPTR                                                59680000
         L     3,ACCTG+4(6)        PICK UP CUMULATIVE TIME              59700000
         BAL   8,PRINTIME          AND CONVERT IT TOO                   59720000
         ICALL LOUT                                                     59740000
         MVC   OBUFPTR(11),ACTMSG2 CHANGE TITLE FROM 'CONN' TO 'CPU'    59760000
         S     6,QFM4              BUMP INDEX UP 4                      59780000
         BZ    ACCL                AND RETURN TO PRINT CPU TIME         59800000
         TCOM  RECEIVE             RCV MESSAGES BEFORE DROPPING LINE    59820000
         L     LKR,=A(SUPPARS)     A(PERTERM) FROM PROTECTED CORE  2230 59840000
         L     LKR,PTBASE-SUPPARD(LKR)                             2230 59860000
         CL    LKR,OPTERM                                          2230 59880000
         BNE   CMOFFY              NOT SIGN OFF OF OPERATOR             59900000
         SVRAPE                    ,PREVENT FUTURE MATCH                59920000
         MVI   OPTERM+1,X'FF'      UNEQUAL TO MPTBASE                   59940000
CMOFFY   CLC   NTEMP(5),QZHOLD     IF COMMAND INCLUDED THE WORD 'HOLD'  59960000
         BNE   CMOFFZ                                                   59980000
         TCOM  OFFH                SIGN OFF BUT HOLD TELEPHONE LINE     60000000
CMOFFZ   TCOM  OFF                 OTHERWISE DROP LINE IMMEDIATELY      60020000
         SPACE 2                                                        60040000
 TITLE 'S Y S T E M   C O M M A N D S   - -   C O P Y   S O U R C E'    60060000
*                                                                       60080000
*              WE ARE SOURCE WORKSPACE FOR A COPY COMMAND.              60100000
*                                                                       60120000
*              SOME OF THE ACTIONS TAKEN HERE DESTROY THE STATE OF THE  60140000
*              SOURCE WORKSPACE, AND MAY BE ALLOWED ONLY BECAUSE THE    60160000
*              SOURCE IS DISCARDED AFTER THE COPY IS DONE.              60180000
COPST    MVC   HOFLN(12),HOFLSET   MAKE SURE FRACTIONAL-LINE-NO LIST    60200000
         MVC   LF108(4),QF108      IS EMPTY                             60220000
         MVI   DPYTOG,DPYALL       'DISPLAY ALL' FOR FUNCTION COPY      60240000
         MVI   COPTOG,COPOBIT      SET COPY-WRITE MODE                  60260000
         MVI   OBUFLIM+1,130       ASSURE WIDE PRINT LINE               60280000
         L     6,=A(COPYID)        POINT TO PARAMETER                   60300000
         CLI   0(6),0                                                   60320000
         BE    COPALL              NO NAME FOLLOWING WORKSPACE NAME IN  60340000
*                                  COMMAND MEANS COPY ALL OBJECTS       60360000
         LA    6,1(6)              SKIP COUNT                           60380000
         BAL   8,SCANID            BUILD, LOCATE, AND CLASSIFY THE IDEN 60400000
         B     COPERR              ALMOST IMPOSSIBLE EXIT               60420000
         LA    8,COPTYI            SUBROUTINE EXIT TO TERMINATE COPY    60440000
         CLI   TUSR,1              CLASSIFY GLOBAL NAME AS ...          60460000
         BL    COPERR              UNDEFINED.  OBJECT NOT FOUND.        60480000
         BE    COPVSUB             VARIABLE.                            60500000
         CLI   TUSR,4                                                   60520000
         BE    COPG                GROUP                                60540000
*                                                                       60560000
*                                  FUNCTION, PENDENT OR OTHERWISE       60580000
*                                                                       60600000
COPFSUB  ST    3,DFNPTR            SET UP FOR PRIFN                     60620000
         BAL   LKR,COPCK           VERIFY EXISTENCE OF DIRECTORY        60640000
         BCR   7,8                 DAMAGED DIRECTORY                    60660000
         IC    0,MHEAD(2)          ESTABLISH PROTECTEDNESS              60700000
         STC   0,PROTOG                                                 60720000
         NI    PROTOG,MFLKBIT                                           60740000
         L     3,MFCODE(2)         ESTABLISH EXISTENCE OF HEADER        60760000
         BAL   LKR,COPCK                                                60780000
         BCR   7,8                 HEADLESS FUNCTION.  IGNORE.          60800000
         ST    8,INLINK            INLINK IS CONVENIENT UNUSED TEMP     60820000
         BAL   LKR,PRIFN           DISPLAY ENTIRE FUNCTION,             60840000
         L     8,INLINK                                                 60860000
         BR    8                                                        60880000
         SPACE 2                                                        60900000
COPG     STM   2,3,CGTEMP1         SAVE GROUP NAME ST LOCATION AND PNAM 60920000
         BAL   LKR,COPCK           VERIFY POINTER                       60940000
         BCR   7,8                                                      60960000
         LH    1,MLSCT(2)          NUMBER OF OBJECTS                    60980000
COPG1    STM   1,2,CGTEMP2         SAVE OBJECT COUNT, ENTRY ADDR        61000000
         L     3,MLSORG(2)         PICK UP SYMBOL TABLE ENTRY OF OBJECT 61020000
         BAL   LKR,TUSAG           FIND GLOBAL MEANING                  61040000
         BAL   8,COPST3            PRESENT IT TO SINK WORKSPACE         61060000
         LM    1,2,CGTEMP2         RECALL COUNT AND ADDR                61080000
         LA    2,4(2)              ADVANCE TO NEXT OBJECT               61100000
         BCT   1,COPG1                                                  61120000
         LM    2,3,CGTEMP1         RECALL GROUP NAME TO COPY ITS DEFN   61140000
         BAL   8,COPGSUB                                                61160000
         B     COPTYI              DONE                                 61180000
*                                                                       61200000
*                                  SUBROUTINE TO COPY GROUP DEFINITION  61220000
COPGSUB  LR    6,2                 HOLD GROUP PRINTNAME FOR DISPLAY     61240000
         BAL   LKR,COPCK           GROUP INTEGRITY VERIFICATION         61260000
*                                  (A GOOD SOCIOLOGY THESIS TOPIC)      61280000
         BCR   7,8                                                      61300000
         LR    3,2                                                      61320000
         LH    4,MLSCT(3)          NUMBER OF OBJECTS                    61360000
         MVC   OBUFPTR+1(8),GRPTXT BEGIN WITH  ')GROUP '                61380000
         BAL   2,PRDENT            DISPLAY GROUP NAME                   61400000
COPGSUB1 ICALL LOUTN               PRINT EACH NAME SEPARATELY, ENDING   61420000
*                                  WITH EOB, TO AVOID CARRIAGE RETS.    61440000
         L     6,MLSORG(3)         NEXT OBJECT SYMBOL TABLE POINTER     61460000
         BAL   2,PRDENT            PRINT ITS NAME                       61480000
         LA    3,4(3)              ADVANCE TO NEXT OBJECT               61500000
         BCT   4,COPGSUB1                                               61520000
         ICALL LOUT                A CARRIAGE RETURN TO END DEFINITION  61540000
         BR    8                                                        61560000
         SPACE     2                                                    61580000
COPALL   L     3,QSYMBOT           PREPARE TO COPY OUT EVERY DEFINED    61600000
*                                  GLOBAL SYMBOL.                       61620000
COPST1   ST    3,ACCTG                                                  61640000
         BAL   LKR,TUSAG           FIND GLOBAL MEANING AND CLASSIFY     61660000
         LA    8,COPST2            RETURN LINK FROM COPY SUBROUTINES    61680000
*              ENTRY TO COPY AN OBJECT FOR GROUP COPY                   61700000
COPST3   CLI   TUSR,1                                                   61720000
         BCR   4,8                 IGNORE UNDEFINED SYMBOLS             61740000
         BE    COPVSUB             VARIABLE                             61760000
         CLI   TUSR,4                                                   61780000
         BL    COPFSUB             FUNCTION                             61800000
         B     COPGSUB             GROUP                                61820000
COPST2   L     3,ACCTG                                                  61840000
         LA    3,8(3)              BUMP TO NEXT SYMBOL                  61860000
         C     3,QR13STK                                                61880000
         BL    COPST1              NOT PAST END OF TABLE -- CONTINUE.   61900000
COPTYI   MVC   OBUFPTR+1(6),SAVMSG END COPY MODE                   3575 61920000
         L     3,WFLTIME           SET UP TO PRINT                      61940000
         BAL   8,PRINTIME          'SAVED HHH.MM.SS  MM/DD/YY'          61960000
         LA    1,WFLDATE                                                61980000
         BAL   8,PRINDATE                                               62000000
         ICALL LOUT                                                     62020000
         TYI                       , THIS ENDS IT                       62040000
*                                                                       62060000
         AGO   .APL3                                                    62080000
.APL3    ANOP                                                           62100000
*        SUBROUTINE TO COPY VARIABLE FROM SOURCE WORKSPACE.             62120000
*        ON ENTRY,                                                      62140000
*              R1 = ABSOLUTE SYMBOL OR STACK ADDR OF GLOBAL             62160000
*              R2 = M-RELATIVE SYMBOL TABLE ADDR FOR PRINT NAME         62180000
*              R3 = M-RELATIVE SYMBOL OR STACK ADDR OF GLOBAL           62200000
*              R8 = LINK                                                62220000
*                                                                       62240000
COPVSUB  LR    6,2                 LET PRDENT PRINT THE VARIABLE NAME   62260000
         BAL   LKR,COPCK           CHECK VALIDITY OF S.T. ENTRY         62280000
         BCR   7,8                 AND GET M-PTR INTO R2                62300000
         L     5,MCOUNT(2)         4-BYTE COUNT FIELD OF M-ENTRY        62320000
COPVS3   BAL   2,PRDENT                                                 62340000
         ST    5,DTEMP+4           FOLLOW NAME BY A ZLENGTH (TO SIGNAL  62360000
         MVC   DTEMP+2(2),Q5LGT    'COPY VARB' FOLLOWED                 62380000
         LA    1,DTEMP+2           BY M-ENTRY COUNT                     62400000
         ICALL SQUIRT                                                   62420000
         ICALL LOUTN               FORCE OUT NAME, ZLENGTH, AND COUNT   62440000
         L     2,M(3)              RECALL M-POINTER                     62460000
         LA    3,128               SET UP TO MOVE VARIABLE IN 128-BYTE  62480000
         L     4,MCOUNT(2)         CHUNKS, VIA TYPEWRITER BUFFER        62500000
         S     4,QAMOVH            WE DON'T MOVE MHEAD OR MCOUNT        62520000
         LA    5,127               WE NEED SS COUNT TOO                 62540000
COPVS1   SR    4,3                 DROP COUNT BY 128                    62560000
         BNP   COPVS2              IS THIS LAST SEGMENT TO BE MOVED --  62580000
         STH   5,MTYPE-2(2)        NO.  STORE SS COUNT IN M-ENTRY JUST  62600000
         TYO   MTYPE-2(2)          BEFORE THIS SEGMENT                  62620000
         AR    2,3                 BUMP SOURCE POINTER BY 128           62640000
         B     COPVS1              AND GO MOVE THE NEXT SEGMENT.        62660000
COPVS2   AR    4,5                                                      62680000
         STH   4,MTYPE-2(2)        MOVE THE LAST SEGMENT SIMILARLY.     62700000
         TYO   MTYPE-2(2)                                               62720000
         BR    8                   RETURN TO CALLER                     62740000
COPERR   TYO   COPERM              COPY ERROR (PRINTED SNEAKILY)        62760000
         B     BEGST2              TERMINATE COPY                       62780000
         SPACE 2                                                        62800000
*              CHECK M-POINTER AND ST-POINTER COINCIDENCE               62820000
*              ON ENTRY,                                                62840000
*                  R3 = M-RELATIVE SYMBOL TABLE OR STACK POINTER        62860000
*                  LKR = LINK                                           62880000
*              ON EXIT,                                                 62900000
*                  R1 = WHAT M-POINTER IN R2 POINTS TO (BYTE 0 = 0)     62920000
*                  R2 = M-POINTER                                       62940000
*                  R3 = SAME AS ON ENTRY EXCEPT BYTE 0 = 0              62960000
*                  CONDITION CODE = 0 IF POINTERS ARE CORRECT           62980000
*                                                                       63000000
COPCK    LA    3,0(3)                                                   63020000
         L     2,M(3)              M-POINTER                            63060000
         L     1,MHEAD(2)          SHOULD POINT BACK TO SYMBOL TABLE    63100000
         LA    1,0(1)              LOSE FLAG BYTE FOR COMPARISON        63140000
         CLR   1,3                 SET CC FOR CALLER                    63160000
         BR    LKR                                                      63180000
 TITLE 'S Y S T E M   C O M M A N D S   - -   S U B R O U T I N E S'    63200000
CVTERM   L     3,=A(SUPPARS)       SUBROUTINE TO CONVERT TERM NO   2230 63220000
         L     5,MPTBASE           LEAVING TENS DIGIT IN R5 AND UNITS   63240000
CVTERMA  CL    5,OPTERM            GIVE APL OPERATOR SPECIAL PORT NO.   63260000
         BE    CVTOP                                                    63280000
         S     5,8+PTBXLE-SUPPARD(3)  IN R4.                       2230 63300000
         SR    4,4                                                      63320000
         D     4,PTBXLE-SUPPARD(3) THIS SHUFFLE GETS TERM NO       2230 63340000
*                                  ADDRESS OF PERTERM AREA              63360000
         CVD   5,PTEMP             CONVERT TERMINAL NO. TO THREE DIGITS 63380000
         MVC   PTEMP(4),CVTPAT     DIGITS ARE TO THE RIGHT              63400000
         ED    PTEMP(4),PTEMP+6                                         63420000
         MVC   0(3,2),PTEMP+1                                           63440000
         TR    0(3,2),VTOZ         CONVERT EBCDIC TO Z                  63460000
         BR    LKR                                                      63480000
CVTOP    MVC   0(3,2),SYSCOPR      OPERATOR TERMINAL MESSAGE ID IS      63500000
         BR    LKR                 'OPR'                                63520000
CVTPAT   DC    X'F0202020'                                              63540000
         SPACE 2                                                        63560000
*              SYSTEM COMMAND IDENTIFIER SCANNER                        63580000
*              SKIPS TO NONBLANK, AND INSERTS FOLLOWING ALPHA INTO      63600000
*              SYMBOL TABLE AND CLASSIFIES GLOBAL DEFINITION VIA TUSAG. 63620000
*              RETURNS TO 0(8) IF NONBLANK IS NOT ALPHA, 4(8) OTHERWISE 63640000
*              ON EXIT,                                                 63660000
*                  R2 = SYMBOL TABLE POINTER (FOR PRINT NAME)           63680000
*                  R3 = SYMBOL TABLE OR STACK POINTER OF GLOBAL         63700000
*                  R0, R1, R4, R5, R6, R7, LKR DESTROYED                63720000
SCANID   BAL   LKR,SKBL                                                 63740000
         CLI   0(6),ZA                                                  63760000
         BCR   4,8                                                      63780000
         CLI   0(6),ZDELTAU                                             63800000
         BCR   2,8                 NONALPHABETIC                        63820000
         ST    8,FTEMP3            SAVE LINK OVER SRCHID                63840000
         BAL   LKR,SRCHID                                               63860000
         BAL   LKR,TUSAG           FIND GLOBAL AND CLASSIFY             63880000
         L     8,FTEMP3                                                 63900000
         B     4(8)                                                     63920000
*                                                                       63940000
PASSUB   EX    0,NEWIDZ            FORM AND HASH SIGNON OR WS PASSWORD  63960000
         CLI   0(6),ZCOLON                                              63980000
         BCR   7,8                                                      64000000
         BAL   LKR,SKBLI           SKIP COLON AND FOLLOWING BLANKS      64020000
         BAL   LKR,BLDID           BUILD 8 CHARS OF PASSWORD            64040000
*              FOLLOWING UNLISTED CODE HASHES THE PASSWORD, LEAVING     64060000
*              IT IN R0, R1.  SUGGEST LEAVING  PRINT OFF  IN TO AVOID   64080000
*              SECURITY PROBLEMS WITH OLD LISTINGS LEFT LYING AROUND.   64100000
*              ALSO DESTROYS R2, R3                                     64120000
         PRINT OFF                                                      64140000
         LM    0,1,NEWID                                                64160000
         LR    2,0                                                      64180000
         LR    3,1                                                      64200000
         SRDL  0,1                                                      64220000
         XR    0,2                                                      64240000
         XR    1,3                                                      64260000
         SRDL  0,3                                                      64280000
         XR    0,2                                                      64300000
         XR    1,3                                                      64320000
         PRINT ON                                                       64340000
*              AS FOR SYSTEM PROGRAMMERS, EVERYONE  K N O W S  THEY'RE  64360000
*              HONEST AND INCORRUPTIBLE.                                64380000
         STM   0,1,NEWID                                                64400000
         BAL   LKR,SKBL                                                 64420000
         B     4(8)                                                     64440000
*                                                                       64460000
*                                                                       64480000
PRINTDAT L     1,=A(ZSYMDATE)                                           64500000
PRINDATE LH    2,OBUFPTR           PRINT ' MM/DD/YY '                   64520000
*                                  R1 = ADDR OF DATE                    64540000
*                                  R3 = VALUE OF REALTIME               64560000
*                                  R8 = LINK                            64580000
         AR    2,MR                MOVE IT DIRECTLY IN TO THE BUFFER    64600000
         MVI   OBUF-M(2),ZBLANK                                         64620000
         MVC   OBUF+1-M(8,2),0(1)                                       64640000
         MVI   OBUF+9-M(2),ZBLANK                                       64660000
         LA    2,10(2)             BUMP THE OUTPUT POINTER              64680000
         SR    2,MR                                                     64700000
         STH   2,OBUFPTR                                                64720000
         BR    8                                                        64740000
*              PRINT BHH.MM.SS                                          64760000
PRINTIME SR    2,2                 REALTIME IS STORED IN 300THS OF SECS 64780000
         LH    7,OBUFPTR                                                64800000
         LA    7,10(7)                                                  64820000
         STH   7,OBUFPTR                                                64840000
         AR    7,MR                                                     64860000
         A     3,QF150             ROUND UP TO SECONDS                  64880000
         D     2,QF300             SCALE DOWN TO SECONDS                64900000
         SR    2,2                                                      64920000
         D     2,QF60              NOW CONVERT FROM RADIX 24,60,60      64940000
         LR    5,2                 TO RADIX 1000,100,100                64960000
         SR    2,2                                                      64980000
         D     2,QF60              GET HOURS                            65000000
         LR    4,2                 AND MINUTES                          65020000
         M     2,QF100             CONVERT TO 'DECIMAL' HOURS AND MINUT 65040000
         AR    3,4                                                      65060000
         M     2,QF100             AND SECONDS                          65080000
         AR    3,5                                                      65100000
         CVD   3,PTEMP             TAKE IT TO DECIMAL                   65120000
         MVC   OBUF-M-10(10,7),PTPAT   THENCE TO                        65140000
         ED    OBUF-M-10(10,7),PTEMP+4 HHH.MM.SS                        65160000
         TR    OBUF-M-10(10,7),VTOZ    KEEP IT IN INTERNAL CODE         65180000
         BR    8                                                        65200000
       TITLE 'F E T C H   A N D   M A S S A G E   N E X T   I N P U T'  65220000
*                                                                       65240000
*        BRING IN THE NEXT LINE FROM THE TERMINAL.                      65260000
*        EDIT OVERSTRIKES AND DELETIONS.  LINE IS TERMINATED BY AN EOB  65280000
*        AND MAY CONTAIN CARRIAGE RETURNS.                              65300000
*        ON ENTRY, THE OUTPUT BUFFER IS EMPTY UNLESS  1) WE ARE INITI-  65320000
*        ATING A SUPEREDIT SEQUENCE OR  2) WE ARE ASKING FOR QUAD-PRIME 65340000
*        INPUT FOLLOWING QUAD-PRIME OUTPUT.  FOR CASE 1, SEE DISCUSSION 65360000
*        AT INLINF.  FOR CASE 2,  LGCPTR  GIVES THE STARTING POSITION   65380000
*        OF THE LAST QUAD-PRIME OUTPUT TEXT IN THE OUTPUT BUFFER.       65400000
*        TEXT LEFT OF LGCPTR IS ACCEPTED AS BLANKS, TEXT RIGHT OF       65420000
*        LGCPTR IS ACCEPTED AS INPUT.                                   65440000
INLINE   ST    LKR,INLINK                                               65460000
         BZ    INLIND                                                   65480000
INLIND   L     4,MPTBASE           WE NEED TO LOOK AT PERTERM.          65500000
         MVC   INLTMP(2),QF2       CLEAR INLTMP                         65520000
         TM    IOB1-PERTERM(4),COPYRM  CHECK IF COPY-SINK               65540000
         BNZ   TYI                 AVOID MESSAGE-SWITCHING.             65560000
         TM    IOB2-PERTERM(4),BOUNCM  HAS APLSUP FORCED SIGNOFF --     65580000
         BZ    INLING                                                   65600000
         TM    IOB1-PERTERM(4),NSIGNM  YES.  INSTANT SIGNOFF IF NOT     65620000
         BO    CMOFFZ              SIGNED ON                            65640000
         EX    0,INL2              (RESET MX BEFORE EXIT)               65660000
         CLI   FDTOG,0             YES.  IF NOT IN FN-DEFINITION,       65680000
         BE    CMFOFF              SIGN OFF IMMEDIATELY.                65700000
         MVC   INBUF(6),UNQIS      OTHERWISE FAKE FN, STMT CLOSERS      65720000
         LA    6,INBUF             TO TELL TYPEIN TO QUIT AFTER         65740000
         B     INL30               CLOSING FUNCTION DEFINITION.         65760000
*              BRANCH TO INLIND FROM INLINQ+ EXECUTES INLINX SPURIOUSLY 65780000
*              WHICH DOESN'T HURT SINCE TOCPTR HASN'T BEEN CHANGED.     65800000
INLINX   MVC   MX(4),TOCPTR        SEE COMMENT AT HEAD OF LISTING       65820000
INLING   MVI   COPTOG,0            SHOULDN'T BE NEEDED TO END COPY      65840000
         BAL   LKR,TYOSD           WE MAY WANT TO PRINT 'STACK DAMAGED' 65860000
         TM    IOB2-PERTERM(4),RECMM                                    65880000
         BC    14,INLINC           IF THIS IS MESSAGE-RECEIVING TERM,   65900000
*              DON'T ASK FOR INPUT.                                     65920000
*              INSTEAD, ENTER THE 'WAIT FOR RESPONSE TO MESSAGE' STATE  65940000
*        SO THAT USER'S SIGNON AND OTHER MESSAGES CAN GET THROUGH.      65960000
*        ASK FOR INPUT ONLY IF OPERATOR PUSHED 'REQUEST' BUTTON.        65980000
INLINM   TCOM  SUSPEND             SUSPEND OPERATOR                     66000000
         ATT   OFF=INLIND          NO ATTENTION -- IT MUST BE MESSAGE   66020000
*                                  OR BOUNCE.                           66040000
*                                                                       66060000
INLINC   CLI   FDTOG,0             ARE WE IN FUNCTION-DEFINITION MODE - 66080000
         BNE   INLINF              YES.  PRINT A LINE NUMBER.           66100000
         TM    QUADTOG,STQBIT+STQPBIT                                   66120000
         BZ    INLINB              IF THIS IS INPUT FOR QUAD OR QUAD',  66140000
         BO    INLINL                                                   66160000
         MVI   INLTMP+1,6          TYPE QUAD, COLON, SPACES, LINEFEED   66180000
*                                  (FOR QUAD ONLY)                      66200000
         MVC   OBUFPTR(9),QUADLN                                        66220000
         MVC   INBUF(6),INDENT+1                                        66240000
         B     INLINH                                                   66260000
*                                  GLORIOUS QUAD-PRIME INPUT AND OUTPUT 66280000
INLINL   LH    1,OBUFPTR           RIGHT END OF TEXT AWAITING OUTPUT    66300000
         STH   1,INLTMP            SAVE RIGHT END FOR INPUT EDITING     66320000
         LTR   1,1                 IF NORMAL (NO OUTPUT) CASE,          66340000
         BZ    TYI                 JUST GET INPUT.                      66360000
         EX    1,INLMVC            ELSE MOVE ENTIRE OUTPUT LINE TO      66380000
         LH    1,TLGCPTR           INPUT BUFFER AND REPLACE WITH BLANKS 66400000
         LTR   1,1                 ANY TEXT NOT GENERATED BY IMMEDI-    66420000
         BNP   INLINH              ATELY PRECEDING CALL OF LOUT         66440000
         MVI   INBUF-1,ZBLANK      THIS IS THE SRA GLITCH TO ALLOW LAST 66460000
         BCTR  1,0                 OUTPUT TO  1) MERELY POSITION THE    66480000
*                                  CARRIER,  2) BE ACCEPTED AS INPUT,   66500000
         EX    1,CEMV3             OR  3) CREATE NIGHTMARISH ANOMALIES. 66520000
         B     INLINH                                                   66540000
QUADLN   DC    AL1(0,7,ZQUAD,ZCOLON,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZLF)    66560000
INLINF   TM    INTOG,CEBIT         IS THIS A CHARACTER EDIT REQUEST --  66580000
         BZ    INLINJ              NO.  NORMAL FUNCTION INPUT.          66600000
*                                                                       66620000
*        WE ARE NOW INITIATING A FANCY CHARACTER-EDITING SEQUENCE.      66640000
*        THE CURRENT STATE OF THE UNIVERSE IS ...                       66660000
*              THE STATEMENT HAS BEEN DISPLAYED, AND IS STILL SITTING   66680000
*              IN OBUF.  THE COUNT (OBUFPTR) HAS BEEN DESTROYED BY LOUT 66700000
*              BUT A COPY IS IN CETMP.                                  66720000
*        WE MUST DO THE FOLLOWING BEFORE RETURNING FROM INLINE ...      66740000
*              PRINT BLANKS TO POSITION THE CARRIAGE IN COLUMN K (THE   66760000
*              COLUMN REQUESTED FOR START OF CONTROL INFORMATION).      66780000
*              ACCEPT INPUT LINE (THE CONTROL LINE) AND MASSAGE IT ON   66800000
*              TOP OF THE BLANKS.                                       66820000
*              USING THE CONTROL LINE, MOVE THE CONTENTS OF THE OUTPUT  66840000
*              BUFFER INTO THE HIGH END OF THE INPUT BUFFER (INBUF+259  66860000
*              DOWNWARD).                                               66880000
*              MOVE THIS RESULT TO THE LOW END OF INBUF.                66900000
*              DISPLAY IT AND ENOUGH BACKSPACES TO POSITION THE         66920000
*              CARRIAGE AT THE LEFTMOST CREATED BLANK.                  66940000
*              ACCEPT INPUT TO MODIFY THE LINE IN INBUF.                66960000
*        CARE MUST BE TAKEN NOT TO LOSE THE OUTPUT BUFFER.  THUS, WE    66980000
*        MUST BYPASS ALL CALLS ON LOUT OR LOUTN IN INLINE.  UGH         67000000
*                                                                       67020000
         LH    1,INBUF-2           FIND REQUESTED STARTING COLUMN       67040000
         LTR   1,1                                                      67060000
         BP    *+8                 TAKE 1 MAX 130 MIN K                 67080000
         LA    1,1                                                      67100000
         C     1,QF130                                                  67120000
         BL    *+8                                                      67140000
         L     1,QF130                                                  67160000
         MVI   INBUF-1,ZBLANK      SET UP LINE OF BLANKS                67180000
*                                  INBUF-1 IS (THROWAWAY) POSITION 0    67200000
         BCTR  1,0                                                      67220000
         EX    1,CEMV3                                                  67240000
         STH   1,INBUF-2           SAVE SS BLANK COUNT                  67260000
         STH   1,INLTMP            SAVE AGAIN FOR MASSAGE SETUP         67280000
         LTR   1,1                 SKIP EMPTY OUTPUT                    67300000
         BZ    TYI                                                      67320000
         LA    1,INBUF(1)                                               67340000
         MVI   0(1),ZEOB           APPEND EOB                           67360000
         TYO   INBUF-2             AND PRINT THE BLANKS.                67380000
         B     TYI                                                      67400000
INLINJ   BAL   LKR,OLINO                                                67420000
INLINA   LH    1,OBUFPTR                                                67440000
         STH   1,INLTMP            ACCEPT LINE NO OR BLANKS AS INPUT    67460000
         EX    1,INLMVC            MOVE TEXT OF LINE NUMBER TO INPUT    67480000
*                                  BUFFER.  THE INTERPRETER-PRINTED     67500000
*                                  LINE NUMBER IS TREATED EXACTLY LIKE  67520000
*                                  TERMINAL INPUT.                      67540000
INLINH   TCOM  RECEIVE             ACCEPT ANY MESSAGES                  67560000
         ICALL LOUTN               FORCE PRINTING, NO CARRIAGE RETURN.  67580000
*                                                                       67600000
*        ENTRY FROM EOBSUBI IN COPY-READ MODE.                          67620000
TYI      TYI                       , REQUEST INPUT                      67640000
         QUEND                     UNNECESSARY EXCEPT FOR COPY, WHICH   67660000
*                                  CAN SPEND SECONDS EMPTYING BUFFER    67680000
         ATT   OFF=INL2            IF ATTENTION WAS SIGNALLED,          67700000
* SEND A CARRIER RETURN WITH MAX IDLES(1050 DOESN'T NEED IDLES),   3587 67720000
* SINCE WE DON'T KNOW WHERE THE CARRIER IS CURRENTLY LOCATED.      3587 67740000
INLINQ   CLI   PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES     3587 67760000
         LA    1,CRIDLE            ASSUME IT IS NOT A 1050,        3587 67780000
         BL    INLINR              AND SEND CR WITH MAX IDLES.     3587 67800000
         LA    1,CRNOIDLE          IT IS A 1050. JUST NEED CR.     3587 67820000
INLINR   ICALL SQUIRT              MOVE CR TO OBUF.                3587 67840000
         ICALL LOUTN               SEND THE CR.                    3587 67860000
*              IF THIS USER IS BEING BOUNCED, SUPERVISOR SETS FORCM     67880000
*              AND RESETS 'AWAITING INPUT' (INWAIT).  THUS WE MUST      67900000
*              TEST AGAIN (AT INL3) FOR FORCED SIGNOFF.                 67920000
         MVI   INTOG,0             SHUN CHARACTER-EDIT MODE             67940000
*                                  TYI WAS IGNORED.  RETRY IT.          67960000
*                                  BRANCH IS TO INLIND TO AVOID TURN-   67980000
*                                  ING ON PROCEED AFTER TERM 0 FINISHES 68000000
*                                  A COPY.                              68020000
*        HOWEVER IT MEANS OP REALLY HAS TO POUND ATTENTION TO GET IN    68040000
*        UNDER CERTAIN CIRCUMSTANCES.                                   68060000
         ATT   OFF=INLIND          WE MANAGED TO PRINT THE CR,EOB       68080000
         B     INLINQ              TIMING PROBLEM, TRY AGAIN            68100000
*                                                                       68120000
INL2     MVC   MX(4),TOCORG        SEE COMMENT AT HEAD OF LISTING       68140000
         L     1,MPTBASE                                                68160000
         TM    IOB1-PERTERM(1),COPYRM                                   68180000
         BZ    INL3                IF 'COPY READ' IS ON,                68200000
*        THIS IS COPY OPERATION, BUFFER IS IN INTERNAL CHARACTERS       68220000
         L     3,PTIBUF-PERTERM(1)                                      68240000
         LA    5,INBUF             INITIALIZE DESTINATION               68260000
         USING PERBUF,3                                                 68280000
INLCP1   MVC   0(L'PBSTAR,5),PBSTAR  MOVE A FULL BUFFER                 68300000
         AH    5,PBCCW+6           INCREMENT DESTINATION                68320000
         TM    PBFLAG,LINEZ        TEST FOR LAST BUFFER                 68340000
         L     3,PBTIC             POINT TO POSSIBLE NEXT BUFFER        68360000
         BZ    INLCP1              YES VIRGINIA, THERE IS ANOTHER BUFF  68380000
*        R5 POINTS JUST BEYOND LAST BYTE OF LINE                        68400000
         BAL   LKR,INL6            JOIN COMMON CODE, INDICATING NO CHAR 68420000
*                                  ERRORS.  NOTE USE OF ILC IN LKR.     68440000
         DROP  3                   PERBUF                               68460000
INLMVC   MVC   INBUF(0),OBUF                                            68480000
*                                                                       68500000
*        ENTRY FROM EOBSUBI, WHICH WANTS AN INPUT LINE WITH NO NONSENSE 68520000
*        EOBSUB SETS RETURN BY STORING LKR IN INLINK.                   68540000
INLINB   LA    1,INDENT            NO LINE NUMBER -- JUST SPACE OVER 6. 68560000
         ICALL SQUIRT                                                   68580000
         B     INLINA                                                   68600000
*                                                                       68620000
*              NOW MASSAGE THE CHARACTER STRING, REMOVING BACKSPACES,   68640000
*              LINEFEEDS, OVERSTRIKES AND SO ON.                        68660000
*              DURING MASSAGE,                                          68680000
*              R3 = SOURCE POINTER (TO SUPERVISOR'S BUFFER)             68700000
*              R4 = SINK POINTER                                        68720000
*              R5 = FIRST UNTYPED POSITION (ALWAYS GEQ R4)              68740000
*              R6 = POINTER TO LEFTMOST CHARACTER ON LINE (LEQ R4)      68760000
*              LKR= POINTER TO LEFTMOST ILLEGAL CHARACTER ON LINE,      68780000
*                   OR NEGATIVE                                         68800000
*              NOTE THAT WE START WITH INTERPRETER-PRODUCED TEXT        68820000
*              ALREADY IN INPUT BUFFER.                                 68840000
*                                                                       68860000
INL3     TM    IOB2-PERTERM(1),BOUNCM MAY HAVE BEEN SET WHILE KYBD 3039 68880000
         BO    INLIND              WAS LOCKED AND WE WERE          3039 68900000
         TCOM  RECEIVE             SUSPEND IN  INWAIT.             3039 68920000
         L     3,PTIBUF-PERTERM(1) POINTER TO FIRST INPUT BUFFER.  3039 68940000
         LA    4,INBUF             SET ALL POINTERS                     68960000
         LA    6,INBUFEND          INITIALIZE MAXIN WITH ADDRESS   3574 68980000
         ST    6,MAXIN             OF LAST VALID INBUF POSITION.   3574 69000000
         MVI   MAXINSW,0                                           3574 69020000
         LR    6,4                                                      69040000
         AH    4,INLTMP                                                 69060000
         LR    5,4                                                      69080000
         MVI   LFTOG,1             ENABLE LINE-DELETE TOGGLE            69100000
*              REENTRY TO FINISH CHARACTER EDITING                      69120000
INL19    EQU   *                                                   3039 69140000
         LCR   LKR,6               LKR NEGATIVE = NO CHARACTER ERROR    69160000
         ST    LKR,SVLKR           CLEAR SVLKR                     3574 69180000
         TM    QUADTOG,STQPBIT     TEST FOR QUAD PRIME                  69200000
         BZ    INL16                                                    69220000
         CLC   PBSTAR-PERBUF(6,3),QZQPOUT GLITCH TO GET OUT OF QUAD-PRI 69240000
         BE    INL18               'O' BS 'U' BS 'T'  WAS TYPED         69260000
INL16    ST    3,OLINK             SAVE BUFFER ADR FOR LINKING TO NEXT  69280000
         LA    3,PBSTAR-PERBUF(3)  ADVANCE TO DATA AREA OF BUFFER       69300000
*              REENTRY TO PROCESS NEXT CHARACTER                        69320000
INL14    CLI   0(3),ZBFZ           IS THIS END OF BUFFER ---            69340000
         BNE   INL20                                                    69360000
         L     3,OLINK             YES.  LOCATE START OF CURRENT BUFFER 69380000
         L     3,PBTIC-PERBUF(3)   AND FIND NEXT ONE.                   69400000
         B     INL16                                                    69420000
INL20    CLI   0(3),ZCR            IS NEXT CHAR A CARRIAGE RETURN --    69440000
         BNE   INL7                NO.                                  69460000
         LTR   6,LKR               TEST FOR ILLEGAL CHARACTERS IN LINE  69480000
         BP    INL6                LKR NONNEG IS ADDR OF ILLEGAL CHAR   69500000
         LA    6,1(5)              CARRIAGE RETURN.  BUMP LEFT-MARGIN   69520000
         LR    4,5                 POINTER AND SOURCE POINTER.          69540000
*              (THE CASE OF A B C BS BS CR)                             69560000
         B     INL11               STUFF CR IN STRING.                  69580000
INL7     CLI   0(3),ZLF            IS NEXT CHAR A LINEFEED --           69600000
         BNE   INL8                NO.                                  69620000
         MVO   LFTOG,LFTOG         YES.  SET LFTOG IF ENABLED BY RBR.   69640000
         CR    LKR,4               SET LKR NEGATIVE IF IT'S CURRENTLY   69660000
         BL    INL5                POINTING AT ILG CH TO THE RIGHT OF   69680000
         LCR   LKR,6               CARRIER.                             69700000
         ST    LKR,SVLKR           UPDATE SAVED VALUE ALSO.        3574 69720000
         B     INL5                RESET RIGHT-HAND-CHAR POINTER        69740000
INL9     TM    MAXINSW,1           LINE EXCEEDED MAX ALLOWABLE?    3574 69760000
         BZ    INL9A               NO.                             3574 69780000
* LKR IS A COUNT OF CHARACTERS PAST INBUF+EMAXIN.  WHEN LKR GOES   3574 69800000
* NEGATIVE, THE USER HAS ENTERED ENOUGH BACKSPACES TO REPOSITION   3574 69820000
* SINK TO THE LEFT OF INBUF+EMAXIN.  WHEN THIS OCCURS, LKR IS      3574 69840000
* RESTORED FROM SVLKR.                                             3574 69860000
INL9B    SH    LKR,QH1             WHEN LKR GOES MINUS,            3574 69880000
         BNM   INL10               SINK IS LEFT OF INBUF+6+MAXIN.  3574 69900000
         L     LKR,SVLKR           RESTORE LKR.                    3574 69920000
INL9C    MVI   MAXINSW,0           RE-ENABLE CODE AT INL11A.       3574 69940000
         BCTR  5,0                 RIGHTMOST CAN'T BE GT SINK.     3574 69960000
INL9A    CR    4,6                 MOVE SINK LEFTWORD              3574 69980000
         BNH   INL10               IF IT'S NOT AT THE LEFT MARGIN       70000000
         BCT   4,INL10             ALREADY.                             70020000
INL8     CLI   0(3),ZEOB           IS NEXT CHAR AN EOB --               70040000
         BE    INL15               YES.                                 70060000
         CLI   0(3),ZBS            NO.  IS IT A BACKSPACE --            70080000
         BE    INL9                YES.                                 70100000
         CL    4,MAXIN             LINE EXCEEDED MAX ALLOWED?      3574 70120000
         BNL   INL11A              YES - IGNORE THE CHARACTER.     3574 70140000
         CLI   0(3),ZBLANK         BLANK IS ONLY CHAR WHICH DOESN'T     70160000
         BE    INL13               AFFECT THE LINEFEED TOGGLE.          70180000
         MVI   LFTOG,0             PREVENT A 'DELETE' SIGNAL FROM       70200000
*                                  BECOMING A 'LINE DELETE' SIGNAL ACCI 70220000
*                                  -DENTALLY.                           70240000
         CLR   LKR,4               LOOK NO FURTHER IF WE ARE TO THE     70260000
         BL    OSB                 RIGHT OF A CHARACTER ERROR           70280000
         CLI   0(3),ZILG           IS IT AN ILLEGAL CHARACTER --        70300000
         BE    OSB                 YES. SOMEONE HIT PREFIX.        C002 70320000
*                                  UPSHIFT ON A 1050, ETC.              70340000
         CLI   0(3),ZRBR           IS CHAR A RIGHT BRACKET --           70360000
         BNE   INL13               NO.  IT'S A NORMAL CHARACTER.        70380000
         MVI   LFTOG,1             ENABLE LINEFEED TOGGLE (USED BY      70400000
*                                  FUNCTION EDITING TO DISTINGUISH      70420000
*                                  BETWEEN A TOTALLY EMPTY LINE AND A   70440000
*                                  STATEMENT-DELETE REQUEST.)           70460000
INL13    CR    4,5                 IF SINK = RIGHTMOST POSITION (NO     70480000
         BNL   INL11               OVERSTRIKE), MOVE SOURCE TO SINK.    70500000
         CLI   0(4),ZBLANK         OR, IF WE ARE OVERSTRIKING A BLANK.  70520000
         BNE   INL12                                                    70540000
INL11    MVC   0(1,4),0(3)                                              70560000
* IF LINE IS PAST INBUF+EMAXIN,  SINK PTR IS NOT UPDATED AND THE   3574 70580000
* CHARACTER IS DUMPED INTO THE BUCKET AT INBUFEND.                 3574 70600000
         CL    4,MAXIN             LINE EXCEEDED MAX ALLOWABLE ?   3574 70620000
         BL    INL17               NO.                             3574 70640000
INL11A   TM    MAXINSW,1                                           3574 70660000
         BO    INL11B                                              3574 70680000
* SINCE THE SINK PTR IS NOT INCREMENTED PAST INBUF+EMAXIN, LKR IS  3574 70700000
* USED TO KEEP TRACK OF HOW MANY CHARACTERS ARE ENTERED PAST       3574 70720000
* INBUF+EMAXIN. THE FOLLOWING CODE IS EXECUTED WHEN SINK REACHES   3574 70740000
* INBUF+EMAXIN. IT SAVES LKR AT SVLKR. LKR IS RESTORED AT INL26    3574 70760000
* SO THAT A CHARACTER ERROR WHICH OCCURED BEFORE INBUF+EMAXIN CAN  3574 70780000
* BE DETECTED.  SVLKR IS INITIALLY SET AT INL19.  IT IS UPDATED    3574 70800000
* HERE AND AT  OSB .                                               3574 70820000
         MVI   MAXINSW,255                                         3574 70840000
         ST    LKR,SVLKR                                           3574 70860000
         SR    LKR,LKR                                             3574 70880000
INL11B   LA    LKR,1(LKR)                                          3574 70900000
         B     INL17A                                              3574 70920000
*              REENTRY FOR IGNORABLE OVERSTRIKES                        70940000
INL17    LA    4,1(4)              UPDATE SINK POINTER                  70960000
INL17A   CR    4,5                 DON'T UPDATE RIGHTMOST PTR      3574 70980000
         BL    INL10               IF IT'S EQUAL TO SINK.               71000000
*              REENTRY FOR LINEFEED                                     71020000
INL5     LR    5,4                                                      71040000
INL10    LA    3,1(3)              UPDATE SOURCE POINTER ALWAYS.        71060000
         B     INL14               BACK FOR NEXT CHARACTER.             71080000
*              ('O' BS 'U' BS 'T') DETECTED IN QUAD PRIME INPUT         71100000
INL18    OI    RUNCTL,RCQEBIT                                           71120000
INL15    MVI   0(5),ZEOB           END OF BLOCK.                        71140000
*                                  STUFF EOB INTO SINK AND QUIT.        71160000
         L     6,MPTBASE                                           3574 71180000
         TM    IOB1-PERTERM(6),NSIGNM DON'T RELEASE BUFFERS        3574 71200000
         BO    INL26               IF NOT SIGNED ON                     71220000
INL6     TCOM  BREL                RELEASE BUFFER CHAIN                 71240000
INL26    L     LKR,SVLKR           SEE COMMENTS AT INL11A.         3574 71260000
         LTR   6,LKR               CHECK FOR CHARACTER ERROR.      3574 71280000
         BP    CHERR                                                    71300000
         TM    MAXINSW,1           DID LINE EXCEED MAX ALLOWABLE?  3574 71320000
         BZ    INL27               NO.                             3574 71340000
         LA    1,RESEND            'RESEND'                        3574 71360000
         LA    6,INBUFEND          POINT TO LAST ALLOWABLE         3574 71380000
         B     PPERR2              INPUT CHARACTER. PRINT 'RESEND' 3574 71400000
INL27    LA    6,INBUF             LOAD ABSOLUTE CHARACTER POINTER 3574 71420000
         TM    INTOG,CEBIT         WAS THIS CONTROL LINE FOR CHARACTER  71440000
         BO    CEDIT               EDIT --  IF SO, LOTS MORE WORK.      71460000
         ST    5,INLCH             SAVE POSITION OF EOB FOR MSG COMMAND 71480000
INL30    L     LKR,INLINK                                               71500000
         BR    LKR                 RETURN WITH MASSAGED LINE IN INBUF.  71520000
*                                                                       71540000
*              OVERSTRIKES.  SOME IGNORED, SOME BOUGHT, SOME ILLEGAL.   71560000
INL12    CLI   0(3),ZBLANK                                              71580000
         BE    INL17               IGNORE OVERSTRIKE BY BLANK.          71600000
         CLC   0(1,3),0(4)         ALSO IGNORE OVERSTRIKE OF A          71620000
         BE    INL17               CHARACTER BY ITSELF.                 71640000
         SR    1,1                 NOW FOR THE GRUBBY PART.             71660000
         IC    1,0(4)              CHECK FOR ALL POSSIBILITIES OF       71680000
*                                  UNDERBAR OVERSTRIKES.  THEY ARE --   71700000
*                              SOURCE        SINK                       71720000
*                                  ALPHA       ..                       71740000
*                                  ..          ALPHA                    71760000
*                                  AULPHA      ..                       71780000
*                                  AULPHA      ALPHA                    71800000
         S     1,QZAU              SUBTRACT OFF 'AU'                    71820000
         BNL   OS1                 IF NEGATIVE, IT'S NOT UNDERBARRED.   71840000
         LA    1,ZAU-ZA(1)         SUBTRACT OFF JUST 'A'                71860000
OS1      CL    1,QF26              IS THIS CHARACTER ALPHABETIC --      71880000
         BH    OS3                 NO.                                  71900000
         CLI   0(3),ZUND           SINK IS ALPHABETIC.  IS SOURCE AN    71920000
         BNE   OS2                 UNDERBAR --                          71940000
OS4      LA    0,ZAU(1)            YES.  MAKE SINK AN UNDERBAR LETTER.  71960000
         B     OS8                                                      71980000
OS2      LA    2,ZA(1)             SINK IS ALPHA OR AULPHA AND SOURCE   72000000
         EX    2,OSCLI             IS NOT AN UNDERBAR                   72020000
         BE    OS4                 SOURCE IS SAME ALPHA.                72040000
         B     OS5                 PROBABLY ILLEGAL OVERSTRIKE          72060000
OSCLI    CLI   0(3),0              EXECUTED CLI                         72080000
OS3      CLI   0(4),ZUND           SINK IS NON-ALPHABETIC.  IS IT UND - 72100000
         BNE   OS5                 NO.  TRY SPECIAL OVERSTRIKES.        72120000
         SR    1,1                                                      72140000
         IC    1,0(3)              PICK UP OFFENDING SOURCE CHARACTER   72160000
         S     1,QZA                                                    72180000
         CL    1,QF26              IS IT ALPHABETIC --                  72200000
         BNH   OS4                 YES.  MAKE SINK CHAR AULPHABETIC.    72220000
         B     OSB                 BAD OVERSTRIKE -- UNDERBAR VS NONALF 72240000
*                                                                       72260000
OS5      IC    0,0(3)              OVERSTRIKE MUST BE A SPECIAL         72280000
*                                  OPERATOR, LIKE VECTOR REVERSAL.      72300000
*                                  SEARCH TABLE OF ALL POSSIBLE WAYS    72320000
*                                  TO OVERSTRIKE SUCH THINGS.           72340000
         SLL   0,24                MAKE SOURCE, SINK CHARACTERS INTO    72360000
         SRA   0,16                A SIGNED HALFWORD.                   72380000
         IC    0,0(4)                                                   72400000
         LA    2,OSP               START OF OVERSTRIKE TABLE            72420000
OS9      LA    1,8                 2 X NO. OF COMBINATIONS TO CONSIDER  72440000
         MVC   DTEMP(8),OSTPAT     MAP 3 CHARS INTO 8                   72460000
         TR    DTEMP(8),0(2)                                            72480000
OS6      CH    0,DTEMP-2(1)        COMPARE POTENTIAL OVERSTRIKE TO ALL  72500000
         BE    OS7                 LEGAL COMBINATIONS                   72520000
         BCTR  1,0                                                      72540000
         BCT   1,OS6                                                    72560000
         LA    2,3(2)              ADVANCE TO NEXT OVERSTRIKE IN TABLE  72580000
         C     2,OSPEND            END TEST                             72600000
         BL    OS9                                                      72620000
OSB      LA    0,ZILG              BAD OVERSTRIKE.  INSERT CANONICAL    72640000
*                                  BAD CHARACTER.                       72660000
         CLR   LKR,4               SET LKR TO LEFTMOST ILG CHARACTER    72680000
         BNH   OS8                                                      72700000
         LR    LKR,4               ON LINE.                             72720000
* SVLKR IS UPDATED BECAUSE THIS ERROR IS LEFT OF THE PREVIOUS ONE. 3574 72740000
         ST    LKR,SVLKR           SAVE UPDATED LKR.               3574 72760000
         B     OS8                                                      72780000
OS7      IC    0,DTEMP+1           PICK UP THE INTERNAL CODE FOR THE    72800000
OS8      STC   0,0(4)              OVERSTRIKE AND PUT IT IN THE SINK.   72820000
         B     INL17                                                    72840000
         SPACE 2                                                        72860000
CEDIT    MVI   INTOG,0             COMBINE OLD DISPLAY AND CONTROL LINE 72880000
*              NOW R6 = ABS ADDRESS OF FIRST CONTROL CHARACTER          72900000
*                  R5 = ABS ADDRESS OF EOB ON CONTROL LINE              72920000
         LR    2,6                 USED LATER FOR ABSOLUTIZING ETC      72940000
         LA    6,260               REL POSITION OF LAST CHAR OF MERGED  72960000
*                                  LINE, PLUS 1                         72980000
         LR    LKR,6                                                    73000000
         SR    5,2                 NUMBER OF CONTROL CHARACTERS, -1     73020000
         LH    4,CETMP             LENGTH OF FUNCTION DISPLAY LINE      73040000
         BCTR  4,0                 IN OBUF, LESS 2 (POINTS TO CR)       73060000
         CR    5,4                 IF CONTROL LINE IS LONGER THAN       73080000
         BNH   CE1                 DISPLAYED STATEMENT,                 73100000
         LR    5,4                 TRUNCATE IT                          73120000
CE1      BCTR  6,0                 DROP RESULT PTR TO NEXT POSITION     73140000
CE2      BCTR  4,0                 DROP DISPLAY POINTER                 73160000
         IC    1,OBUF(4)           MOVE CHAR FROM STATEMENT DISPLAY     73180000
         STC   1,INBUF(6)          TO MERGE AREA                        73200000
         CR    5,4                 HAVE WE REACHED THE CONTROL INFO --  73220000
         BNH   CE1                 NO.  NO CONTROL FOR RIGHT END OF LIN 73240000
         LA    3,INBUF-1(5)        YES.  LOOK AT CONTROL CHARACTER.     73260000
         CLI   0(3),ZSLASH                                              73280000
         BE    CE8                 SLASH DELETES CHAR FROM STATEMENT    73300000
*                                  BY NOT UPDATING MERGE POINTER        73320000
         SR    1,1                                                      73340000
         IC    1,0(3)              PICK UP CONTROL CHAR                 73360000
         SH    1,QZ9               LOOK FOR DECIMAL DIGIT               73380000
         BP    CE7                                                      73400000
         A     1,QF9                                                    73420000
         BNM   CE5                 (IT IS)                              73440000
         AH    1,QH55              OR ALPHABETIC                        73460000
         BNH   CE7                 TREAT AS A BLANK OTHERWISE           73480000
         MH    1,QH5               ALPHA BECOMES 5 * A...Z IOTA CHAR    73500000
CE5      BZ    CE3                 NO INSERT IF 0 -- JUST MARK IT  2539 73520000
         LA    0,ZBLANK                                            2539 73540000
CE4      BCTR  6,0                 DROP MERGE POINTER                   73560000
         C     6,QF130             STOP A RUNAWAY INSERT NOW       2539 73580000
         BL    CEFNERR                                             2539 73600000
         STC   0,0(6,2)            LENGTH UNDER 130, INSERT BLNK   2539 73620000
         BCT   1,CE4               TEST BLANK-INSERTION COUNT           73640000
CE3      LR    LKR,6               RECALL LEFTMOST BLNK ADDR FOR   2539 73660000
*                                  COMPUTED BACKSPACE COUNT             73680000
CE7      BCTR  6,0                 DROP MERGE PTR TO NEXT FREE SPACE    73700000
         C     6,QF130             CHECK LENGTH OF MERGED LINE          73720000
         BL    CEFNERR             WHOOPS -- LONGER THAN PRINT LINE     73740000
CE8      BCT   5,CE2               BACK FOR MORE IF CONTROL INFO IS     73760000
*                                  NOT FINISHED.  NOTE CONTROL LINE     73780000
*                                  HAS AT LEAST 1 CHARACTER -- EOB.     73800000
         LA    5,259                                                    73820000
         SR    LKR,6               COLUMN TO BACKSPACE TO               73840000
         BCTR  LKR,0                                                    73860000
         SR    5,6                 LENGTH OF MERGED LINE                73880000
         STH   5,INLTMP            LINE LEN. FOR UPCOMING MASSAGE. 3587 73900000
         BZ    CE10                                                     73920000
         L     1,MPTBASE           PERTERM ADDRESS.                3587 73940000
         CLI   PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES     3587 73960000
         BNL   CE9                 SO DON'T SEND ANY.              3587 73980000
* TYO USED CARRPOS TO COMPUTE IDLES TO PREVENT OVERPRINT.          3587 74000000
         STH   5,CARRPOS-M(MR)     CURRENT CARRIER POSITION.       3587 74020000
CE9      EQU   *                                                   3587 74040000
         AR    6,2                 REL ADDR, LEFT END OF MERGE LINE     74060000
         EX    5,CEMV1             MOVE MERGE LINE DOWN INTO LOW INBUF  74080000
         STH   5,INBUF-2                                                74100000
         LA    0,ZEOB                                                   74120000
         STC   0,INBUF(5)          NO CR -- WE STAY ON SAME LINE FOR BS 74140000
         SR    5,LKR               NUMBER OF BACKSPACES REQUIRED        74160000
         MVI   OBUF,ZBS            FILL OUTPUT BUFFER WITH BACKSPACES   74180000
         EX    5,CEMV2                                                  74200000
         STC   0,OBUF(5)                                                74220000
         EX    0,INLINX            GET MX SET WRONG AGAIN               74240000
         TYO   INBUF-2             TYPE MERGED LINE                     74260000
         LTR   5,5                 FOLLOWED (IF NECESSARY)              74280000
         BZ    CE10                                                     74300000
         STH   5,OBUFPTR           BY BACKSPACES                        74320000
         TYO   OBUFPTR                                                  74340000
         MVC   OBUFPTR(2),QF2      SET OBUFPTR TO ZERO             3587 74360000
CE10     TYI                       ACCEPT INPUT (CHANGES FOR LINE       74380000
*                                  SITTING IN INBUF).                   74400000
         L     1,MPTBASE           TO GET PTIBUF ADDRESSABILITY         74420000
         ATT   ON=INLINQ,MPTBASE=(1)                                    74440000
         CLI   PTTYPE-PERTERM(1),Q1050 1050 DOESN'T NEED IDLES     3587 74460000
         BNL   CE16                SO DON'T SEND ANY.              3587 74480000
* SEND IDLES TO PREVENT OVERPRINT. NUMBER OF IDLES IS COMPUTED BY  3587 74500000
* FINDING THE LENGTH OF THE EDITED LINE IN INBUF.                  3587 74520000
         L     3,PTIBUF-PERTERM(1) FIRST BUFFER ADDRESS.           3587 74540000
         SR    6,6                 POINT PAST WHAT'S               3587 74560000
         LH    6,INLTMP            ALREADY BEEN ENTERED.           3587 74580000
         LA    5,1                 INCREMENT FOR CE12              3587 74600000
         B     CE11                                                3587 74620000
CE14     L     3,PBTIC-PERBUF(3)   ADDRESS OF NEXT BUFFER.         3587 74640000
CE11     LA    4,PBSTAR-PERBUF-1(3)  POINT TO DATA AREA.           3587 74660000
CE12     LA    4,1(4)              LOOK AT THE NEXT CHAR.          3587 74680000
         CLI   0(4),ZBFZ           END OF BUFFER?                  3587 74700000
         BE    CE14                YES-GET THE NEXT ONE.           3587 74720000
         CLI   0(4),ZEOB           ZEOB IS THE END OF THE LINE.    3587 74740000
         BE    CE15                END OF THE LINE                 3587 74760000
         CLI   0(4),ZBS            BACKSPACE?                      3587 74780000
         BNE   CE17                NO.                             3587 74800000
         S     6,QF2               DON'T LET BACKSPACE FOOL US.    3587 74820000
CE17     BXH   6,5,CE12            KEEP TRACK OF WHERE WE ARE.     3587 74840000
CE15     STH   1,CARRPOS-M(MR)     CURRENT CARRIER POSITION.       3587 74860000
CE16     L     3,PTIBUF-PERTERM(1) FOR INL19                       3587 74880000
         EX    0,INL2              RESET MX TO CODESTRING ORIGIN        74900000
         LA    4,INBUF(LKR)        POSITION SINK PTR AT 1ST INSERTED    74920000
*                                  BLANK.                               74940000
         LA    6,INBUF             THIS PARALLELS SETUP AT INL3         74960000
         LR    5,6                                                      74980000
         AH    5,INBUF-2                                                75000000
         B     INL19                                                    75020000
CEMV1    MVC   INBUF(0),1(6)       THE EXECUTED MVC'S                   75040000
CEMV2    MVC   OBUF+1(0),OBUF                                           75060000
CEMV3    MVC   INBUF(0),INBUF-1                                         75080000
*                                                                       75100000
OLINO    ST    LKR,OLINK                                                75120000
         LA    1,ZLBR              PRINT BRACKETED LINE NUMBER.         75140000
         ICALL TOPRINT             FIRST THE LEFT BRACKET               75160000
         MVC   DMASK+4(4),FLINENO  FLOAT THE LINE NUMBER                75180000
         LD    0,DMASK                                                  75200000
         DD    0,D10000            AND READJUST IT TO TRUE FRACTION     75220000
         STD   0,DTEMP                                                  75240000
         LM    0,1,DTEMP                                                75260000
         L     4,OSIGDIG           SAVE CURRENT )DIGITS SETTING         75280000
         MVI   OSIGDIG+3,8         WHILE WE PRINT THE LINE NUMBER       75300000
         SR    3,3                                                      75320000
         LA    2,3                 LOAD PARAMETERS FOR OUTPUT           75340000
         ICALL TOBCD               CONVERSION AND CONVERT THE LINE NO.  75360000
*                                  TOBCD WILL PRINT IT WITH NO LEADING  75380000
*                                  SPACES AND WITH NO TRAILING FRAC-    75400000
*                                  TIONAL ZEROES.                       75420000
         ST    4,OSIGDIG           RESTORE PROPER SIG DIGITS SETTING    75440000
         LA    1,ZRBR              APPEND RIGHT BRACKET                 75460000
         ICALL TOPRINT                                                  75480000
OLIN2    LA    1,ZBLANK            AND AT LEAST ONE BLANK               75500000
         ICALL TOPRINT                                                  75520000
         CLI   OBUFPTR+1,6         ENSURE INDENTATION OF AT LEAST 6     75540000
         BL    OLIN2                                                    75560000
         L     LKR,OLINK                                                75580000
         BR    LKR                                                      75600000
         TITLE 'C O N S T A N T S   A N D   D S E C T S'                75620000
Q1050    EQU   64                  PTTYPE FOR 1050.                3587 75640000
CRNOIDLE DC    AL1(1,ZCR)          CR.                             3587 75660000
CRIDLE   DC    AL1(16,ZCR)         CR AND MAX IDLES.               3587 75680000
         DC    15AL1(ZEOB)                                         3587 75700000
INDENT   DC    AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZBLANK)         75720000
PRIDEL   DC    AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZDEL,ZBLANK)           75740000
PRIPDEL  DC    AL1(6,ZBLANK,ZBLANK,ZBLANK,ZBLANK,ZPDEL,ZBLANK)          75760000
UNQIS    DC    AL1(ZDEL,ZCR,ZQUOTE,ZDEL,ZCR,ZEOB)                       75780000
Q5LGT    DC    AL1(5,ZLENGTH)                                           75800000
         DC    FL1'0'              FILL                                 75820000
         DC    0F'0'               ALIGNMENT                            75840000
         ORG   *-1                 TO FULLWORD BYTE 3                   75860000
*                                  NEXT 3 CARDS MUST BE IN SEQUENCE     75880000
BITB     DC    X'80'                                                    75900000
FOLDER   DC    X'40201008'                                              75920000
         DC    X'040201'                                                75940000
QZQPOUT  DC    AL1(ZO,ZBS,ZU,ZBS,ZT,ZCR) 'O' BS 'U' BS 'T' CR           75960000
QZSD     DC    AL1(ZS,ZDELTA)                                           75980000
QZTD     DC    AL1(ZT,ZDELTA)                                           76000000
QZ9      DC    Y(Z9)                                                    76020000
QH1      DC    H'1'                                                     76040000
QH5      DC    H'5'                                                     76060000
QH16     DC    H'16'                                                    76080000
QH55     DC    H'55'                                                    76100000
QH126    DC    H'126'                                                   76120000
QH255    DC    H'255'                                              3574 76140000
OPMAN    DC    F'314159'           MAN NUMBER FOR OPERATOR              76160000
OPTERM   DC    A(0)                MODIFIED TO POINT TO PERTERM $ $ $ $ 76180000
QFDFN    DC    AL1(DFN,0,0,0)      CHECKS FOR NON-VARS IN S.T.     3036 76200000
QFM21    DC    F'-21'                                                   76220000
QFM4     DC    F'-4'                                                    76240000
QFM2     DC    F'-2'                                                    76260000
QF2      DC    F'2'                                                     76280000
QF3      DC    F'3'                                                     76300000
QF7      DC    F'7'                                                     76320000
QF8      DC    F'8'                                                     76340000
QF9      DC    F'9'                                                     76360000
QF10     DC    F'10'               CHARACTERS PER IDLE.            3587 76380000
QF11     DC    F'11'                                                    76400000
QF12     DC    F'12'                                                    76420000
QF26     DC    F'26'                                                    76440000
QF60     DC    F'60'                                                    76460000
QF77     DC    F'77'                                                    76480000
QF100    DC    F'100'                                                   76500000
QF130    DC    F'130'                                                   76520000
QF150    DC    F'150'                                                   76540000
QF300    DC    F'300'                                                   76560000
         AGO   .SOX7                                                    76580000
.SOX7    ANOP                                                       SOX 76620000
QPLMSK   DC    X'FFFF000F'         FOR MASKING OUT LABEL COUNT IN DIR   76640000
QF9S     DC    F'9999.9999E4'                                           76660000
HOFLSET  DC    F'0,-1,0'           INITIAL VALUE FOR FRACTIONAL-LINE-NO 76680000
*                                  LIST USED IN CRL.                    76700000
QF108    DC    F'1E8'              MUST FOLLOW HOFLSET                  76720000
QZ0      DC    A(Z0)                                                    76740000
QFCVL    DC    F'429496729'        ONE TENTH WORD CAPACITY              76760000
ATYPTOP  DC    A(TYPTOP)                                                76780000
QAMOVH   DC    A(MTYPE-M)          M-ENTRY OVERHEAD                     76800000
QCODCLS  DC    A(CDST*X'1000'*X'1000')                                  76820000
UNVAR    DC    AL1(VARB,0,0,0)                                          76840000
QINTYPE  DC    FL1'2,0,0,0'                                             76860000
QLOWNM   EQU   QINTYPE             QLOWNM IS JUST N000 , N LEQ 3        76880000
         DS    0F                                                       76900000
QLSTCODE DC    AL1(MLSTBIT,0,0,0)                                       76920000
QGRCODE  DC    AL1(GROUP,0,0,0)                                         76940000
         DC    0D'0'                                                    76960000
DTOPS    DC    X'4E000000'         TOP OF 1ST UNNORMALIZED FL PT CONST  76980000
QFMSMALL DC    X'80000000'                                              77000000
         DC    X'56000000'         TOP OF 2ND UNNORMALIZED FL PT CONST  77020000
QF24BITS DC    X'00FFFFFF'         A CONVENIENT SPOT                    77040000
*              YOU GUESSED IT -- THEY MUST BE 8 APART.                  77060000
ERND     DC    D'.5'                                                    77080000
DUNZ     DC    X'4E00000000000000'                                      77100000
D10      DC    D'10'                                                    77120000
D3000    DC    D'3000'                                                  77140000
D10000   DC    D'10000'                                                 77160000
D106     DC    D'1000000'                                               77180000
D16M14   DC    X'3310000000000000'                                      77200000
D1614    DC    X'4F10000000000000'                                      77220000
INFIN    DC    X'7FFFFFFFFFFFFFFF'                                      77240000
PTPAT    DC    X'FA202120FB2020FB2020'                                  77260000
*                                  'NUMBER NOT IN SYSTEM'               77280000
SOPFTXT  DC    H'21'                                                    77300000
         DC    AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZN,ZO,ZT,ZBLANK,ZI,ZN,ZBLANK77320000
               K,ZS,ZY,ZS,ZT,ZE,ZM,ZCR,ZEOB)                            77340000
*                                  'NUMBER IN USE'                      77360000
SOPDTXT  DC    H'14'                                                    77380000
         DC    AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZI,ZN,ZBLANK,ZU,ZS,ZE,ZCR,ZE77400000
               EOB)                                                     77420000
*                                  'INCORRECT SIGN-ON'                  77440000
SOPERTX  DC    H'18'                                                    77460000
         DC    AL1(ZI,ZN,ZC,ZO,ZR,ZR,ZE,ZC,ZT,ZBLANK,ZS,ZI,ZG,ZN,ZMINUS,77480000
               ,ZO,ZN,ZCR,ZEOB)                                         77500000
QZHOLD   DC    AL1(4,ZH,ZO,ZL,ZD)  'HOLD'                               77520000
*                                  'NUMBER LOCKED OUT'                  77540000
SOPLKTX  DC    H'18'                                                    77560000
         DC    AL1(ZN,ZU,ZM,ZB,ZE,ZR,ZBLANK,ZL,ZO,ZC,ZK,ZE,ZD,ZBLANK,ZO,77580000
               ,ZU,ZT,ZCR,ZEOB)                                         77600000
CMWASMSG DC    AL1(4,ZW,ZA,ZS,ZBLANK)            'WAS '                 77620000
*                                  'ALREADY SIGNED ON'                  77640000
SOPNDTXT DC    H'18'                                                    77660000
         DC    AL1(ZA,ZL,ZR,ZE,ZA,ZD,ZY,ZBLANK,ZS,ZI,ZG,ZN,ZE,ZD)       77680000
         DC    AL1(ZBLANK,ZO,ZN,ZCR,ZEOB)                               77700000
*                                  'INCORRECT COMMAND'                  77720000
BADCOM   DC    H'18'                                                    77740000
         DC    AL1(ZI,ZN,ZC,ZO,ZR,ZR,ZE,ZC,ZT,ZBLANK,ZC,ZO,ZM,ZM,ZA,ZN,Z77760000
               ZD,ZCR,ZEOB)                                             77780000
*                                  'NOT WITH OPEN DEFINITION'           77800000
NOTINFN  DC    H'25'                                                    77820000
         DC    AL1(ZN,ZO,ZT,ZBLANK,ZW,ZI,ZT,ZH,ZBLANK,ZO,ZP,ZE,ZN,ZBLAN.77840000
               K,ZD,ZE,ZF,ZI,ZN,ZI,ZT,ZI,ZO,ZN,ZCR,ZEOB)                77860000
         AGO   .SOX8                                                    77880000
.SOX8    ANOP                                                       SOX 77960000
VTOZ     EQU   *-C'0'              VD TO INTERNAL CODE                  77980000
         DC    AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,ZBLANK,ZPER)           78000000
*                                  'CONNECTED XX/XX/XX ,  TO DATE '     78020000
ACTMS1   DC    AL1(0,10,ZC,ZO,ZN,ZN,ZE,ZC,ZT,ZE,ZD,ZBLANK,0,0,0,0,0,0,0,78040000
               )                                                        78060000
         DC    AL1(0,ZBLANK,ZCOMMA,ZBLANK,ZBLANK,ZT,ZO,ZBLANK,ZD,ZA,ZT,X78080000
               ZE,ZBLANK)                                               78100000
ACTMSG2  DC    AL1(0,10,ZC,ZP,ZU,ZBLANK,ZT,ZI,ZM,ZE,ZBLANK)  'CPU TIME' 78120000
         DS    0H                                                       78140000
SPDSAVE  DC    AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE,0,0,0)                     78160000
         DC    Y(XXSAVE)           )SAVE OP CODE                        78180000
SAVMSG   DC    AL1(5,ZS,ZA,ZV,ZE,ZD)   'SAVED'                          78200000
COPERM   DC    H'17'               'OBJECT NOT FOUND'              3575 78220000
         DC    AL1(ZO,ZB,ZJ,ZE,ZC,ZT,ZBLANK,ZN,ZO,ZT,ZBLANK)       3575 78240000
         DC    AL1(ZF,ZO,ZU,ZN,ZD,ZCR,ZEOB)                        3575 78260000
*                                  'NOT GROUPED, NAME IN USE'           78280000
GRPTXT   DC    AL1(7,ZRPAR,ZG,ZR,ZO,ZU,ZP,ZBLANK)  ')GROUP '            78300000
CMGRNUSD DC    H'25'                                                    78320000
         DC    AL1(ZN,ZO,ZT,ZBLANK,ZG,ZR,ZO,ZU,ZP,ZE,ZD,ZCOMMA,ZBLANK)  78340000
         DC    AL1(ZN,ZA,ZM,ZE,ZBLANK,ZI,ZN,ZBLANK,ZU,ZS,ZE,ZCR,ZEOB)   78360000
RESEND   DC    AL1(6)              'RESEND'                        3574 78380000
         DC    AL1(ZR,ZE,ZS,ZE,ZN,ZD)                              3574 78400000
QZA      DC    A(ZA)                                                    78420000
QZAU     DC    A(ZAU)                                                   78440000
QZ8BIT   DC    A(ZA-1)                                                  78460000
QZDAU    DC    A(ZDELTAU)                                               78480000
P10      DC    F'1,10,100,1000,10000'                                   78500000
F102     EQU   P10+8                                                    78520000
PUBPRI   EQU   P10+12                                                   78540000
F103     EQU   P10+12                                                   78560000
F104     EQU   P10+16                                                   78580000
*              TABLE OF LEGITIMATE SPECIAL OVERSTRIKES                  78600000
OSP      DC    AL1(ZCIRCLE,ZMOD,ZREV)                                   78620000
         DC    AL1(ZQUOTE,ZPER,ZSHRIEK)                                 78640000
         DC    AL1(ZCIRCLE,ZBSLASH,ZTRAN)                               78660000
         DC    AL1(ZCIRCLE,ZSTAR,ZLOG)                                  78680000
         DC    AL1(ZBASE,ZREP,ZHIST)                                    78700000
         DC    AL1(ZAND,ZNOT,ZNAND)                                     78720000
         DC    AL1(ZOR,ZNOT,ZNOR)                                       78740000
         DC    AL1(ZCAP,ZNULL,ZREM)                                     78760000
         DC    AL1(ZQUOTE,ZQUAD,ZQUADP)                                 78780000
         DC    AL1(ZDEL,ZNOT,ZPDEL)                                     78800000
         DC    AL1(ZDELTA,ZMOD,ZUPGRADE)                                78820000
         DC    AL1(ZDEL,ZMOD,ZDNGRADE)                                  78840000
         DC    AL1(ZCIRCLE,ZMINUS,ZCOLREV)                              78860000
         DC    AL1(ZSLASH,ZMINUS,ZCOLSLSH)                              78880000
         DC    AL1(ZBSLASH,ZMINUS,ZCOLBSLH)                             78900000
         DC    AL1(ZQUAD,ZDIV,ZDOMINO)                                  78920000
*              TABLE OF PSEUDO-LEGITIMATE SPECIAL OVERSTRIKES           78940000
         DC    AL1(ZCOMMA,ZPER,ZCOMMA)                                  78960000
         DC    AL1(ZSEMIC,ZPER,ZSEMIC)                                  78980000
         DC    AL1(ZCOLON,ZCOMMA,ZSEMIC)                                79000000
         DC    AL1(ZSEMIC,ZCOLON,ZSEMIC)                                79020000
         DC    AL1(ZSEMIC,ZCOMMA,ZSEMIC)                                79040000
         DC    AL1(ZCOLON,ZPER,ZCOLON)                                  79060000
         DC    AL1(ZPLUS,ZMINUS,ZPLUS)                                  79080000
         DC    AL1(ZDIV,ZMINUS,ZDIV)                                    79100000
         DC    AL1(ZDOMINO,ZMINUS,ZDOMINO)                              79120000
         DC    AL1(ZNE,ZEQ,ZNE)                                         79140000
         DC    AL1(ZEQ,ZSLASH,ZNE)                                      79160000
         DC    AL1(ZL,ZF,ZE)       THE DARK, IMMORAL SIDE               79180000
         DC    AL1(ZF,ZE,ZE)                                            79200000
         DC    AL1(ZO,ZQ,ZQ)       OF VISUAL FIDELITY                   79220000
         DC    AL1(ZL,ZE,ZE)                                            79240000
         DC    AL1(ZP,ZR,ZR)                                            79260000
         DC    AL1(ZI,ZT,ZT)                                            79280000
         DC    AL1(ZMAX,ZMIN,ZLBR)                                      79300000
         DC    AL1(ZQUOTE,ZCOLON,ZSHRIEK)                               79320000
         DC    AL1(ZPER,ZQUERY,ZQUERY)                                  79340000
         DC    AL1(ZMINUS,ZLARROW,ZLARROW)                              79360000
         DC    AL1(ZMINUS,ZRARROW,ZRARROW)                              79380000
         DC    AL1(Z3,Z8,Z8)                                            79400000
         AGO   .DOL1                                                    79420000
.DOL1    ANOP                                                      F005 79480000
OSPEND   DC    A(*-1)                                                   79500000
OSTPAT   DC    FL1'1,2,0,2,1,0,0,1'  TRANSLATE TABLE FOR OVERSTRIKES    79520000
         LTORG                                                          79540000
FLENT    DSECT                     FORM OF ENTRY IN FRACTIONAL-LINE LST 79560000
FLENTCSA DS    A                   CODESTRING ADDRESS                   79580000
FLENTNO  DS    F                   FRACTIONAL LINE NO * 10000           79600000
FLENTLNK DS    A                   ADDR OF NEXT HIGHER LINE NUMBER      79620000
PREPLOC  DSECT                                                          79640000
         DS    4F                  MUST BE ZERO TO END SUP BACKTRACE    79660000
DLINENO  DS    D                   LINE NUMBER BUMPING WORKSPACE        79680000
NTEMP    DS    D                                                        79700000
DTEMP    DS    D                   ICV FLOATING WORKSPACE               79720000
DMASK    DS    D                                                        79740000
DNASK    DS    D                                                        79760000
PTEMP    DS    D                                                        79780000
SKBTEMP  DS    7F                                                       79800000
INLINK   DS    A                   INLINE RETURN ADDR                   79820000
OLINK    DS    A                   RETURN ADDRESS FOR OLINO             79840000
INLCH    DS    F                   ABS ADDR OF EOB IN INPUT             79860000
NEWID    DS    2F                                                       79880000
HN       DS    2F                  ICV FIXED-POINT FRACTION             79900000
LN       EQU   HN+4                                                     79920000
EN       DS    F                   ICV DECIMAL EXPONENT                 79940000
CCNT     DS    3F                  NUMBER OF CONSTANTS IN CODESTRING    79960000
*                                  VECTOR                               79980000
FTEMP1   EQU   CCNT+4                                                   80000000
TOCSAV   EQU   CCNT+8              SAVED COPY OF CODESTRING POINTER     80020000
FTEMP2   DS    F                                                        80040000
TOCORG   DS    2F                  M-REL POINTER TO CODESTRING ORIGIN   80060000
TOCPTR   EQU   TOCORG+4            M-REL POINTER TO SYL POS IN CODESTR  80080000
SRCHRET  DS    2A                                                       80100000
DELIT    DS    A                   LINK BACK FOR DELIDS                 80120000
DFNPTR   DS    F                   S.T. PTR OF DFN BEING DEFINED        80140000
*                                  EVEN IF HEADER HAS BEEN CHANGED      80160000
PINAB    DS    3F                  FN POINTER, IN ABEYANCE              80180000
LINAB    EQU   PINAB+4             LOCALS COUNT, IN ABEYANCE            80200000
CINAB    EQU   PINAB+8             CLASS (DFN OR DFN0), IN ABEYANCE     80220000
FDTOG    DS    FL1                 FUNCTION-DEFINITION INDICATOR        80240000
FDDHBIT  EQU   X'01'               DEFINING FUNCTION HEADER             80260000
FDDFBIT  EQU   X'02'               FUNCTION DEFINITION MODE PROPER      80280000
FDCLBIT  EQU   X'04'               CLOSING FUNCTION DEFINITION          80300000
PROTOG   DS    FL1                 LOCK BIT FOR FN BEING DEFINED        80320000
LASTID   DS    F                                                        80340000
SVIT     DS    F                   TOP OF NEW PNAMES, BOT OF FLENTS     80360000
HOFLN    DS    3F                  HEAD OF FRACTIONAL-LINE-NO. LIST     80380000
LF108    DS    F                   VERY LARGE LINENO TO END LINTRAC SCH 80400000
ILN      DS    4F                  NEXT INTEGER LINE NO (FN EDITING)    80420000
ILNPTR   EQU   ILN+4               POINTER TO ILN'S CODESTRING POINTER  80440000
*                                  IN 3-WORD-ENTRY LIST ON STACK        80460000
FRLNPTR  EQU   ILN+8               POINTER TO FRLN'S CODESTRING POINTER 80480000
*                                  IN FUNCTION DIRECTORY                80500000
ENDIR    EQU   ILN+12              M-REL ADDR OF END OF FN DIRECTORY    80520000
PRIFT    DS    2F                  POINTER TO CODESTRING OF LAST STMT   80540000
*                                  LOOKED AT BY PRIFN                   80560000
FLINENO  EQU   PRIFT+4             DECIMAL MIDPOINT FUNCTION LINE NO.   80580000
PRIFR    DS    A                   RETURN ADDRESS FOR PRIFN             80600000
LINTF    DS    F                   ADDR OF LAST CODESTRING PTR          80620000
*                                  WITH NUMBER LESS THAN CURRENT ON     80640000
*                                  FRACTIONAL-LINE-NUMBER LIST          80660000
SCSCNT   DS    F                   TEMP, NEW CS BYTE COUNT IN FN DEFN   80680000
FTEMP3   DS    F                   LINK FROM SCANID                     80700000
CTYP     DS    F                                                        80720000
ININTMP  DS    A                   RETURN LINK FOR ININT                80740000
SCIMAGE  DS    2F                  SYSTEM COMMAND CONTROL INFO          80760000
SCNAME   EQU   SCIMAGE             4 CHARACTERS OF COMMAND NAME         80780000
SCAD     EQU   SCIMAGE+4           HALFWORD OF COMMAND ROUTINE ADDRESS  80800000
SCNO     EQU   SCIMAGE+6           USEFUL BYTE WITH VARYING MEANINGS    80820000
SCFLG    EQU   SCIMAGE+7           FLAGS GIVING COMMAND SYNTAX          80840000
ACCTG    DS    4F                  ACCOUNTING INFORMATION AT SIGNOFF    80860000
*              CUMULATIVE CONNECTION TIME                               80880000
*              TODAY'S CONNECTION TIME                                  80900000
*              CUMULATIVE CPU TIME                                      80920000
*              TODAY'S CPU TIME                                         80940000
CGTEMP1  DS    2F                  REG SAVE IN COPY GROUP               80960000
CGTEMP2  DS    2F                  REG SAVE IN COPY GROUP               80980000
TUST     DS    F                   PUTATIVE GLOBAL POINTER IN TUSAG     81000000
INLTMP   DS    H                   INLINE TEMP FOR LINE NO. POS & LENGT 81020000
CETMP    DS    H                   SS COUNT OF DISPLAYED UNEDITED LINE  81040000
TLGCPTR  DS    H                   OBUF POS OF 1ST CHAR, LAST OUTPUT    81060000
*                                  (FOR QUAD-PRIME INPUT OUTPUT-IGNORE) 81080000
TUSR     DS    FL1                 OUTCOME OF LOOKING IN STACK FOR FN   81100000
OFFTOG   DS    FL1                 SIGN-OFF FORCED BY SUPERVISOR        81120000
LFTOG    DS    FL1                 LINEFEED SEEN FOLLOWING RIGHTMOST    81140000
*                                  RIGHT BRACKET (USED BY FN EDITING)   81160000
DPYTOG   DS    FL1                 LINE AND FUNCTION DISPLAY TOGGLE     81180000
COPTOG   DS    FL1                 COPY/PCOPY SINK TOGGLE               81200000
COPIBIT  EQU   X'01'               COPY SINK                            81220000
COPPBIT  EQU   X'02'               PCOPY                                81240000
COPVBIT  EQU   X'04'               USED BY COPY-VARIABLE SINK           81260000
COPOBIT  EQU   X'10'               COPY SOURCE                          81280000
DSTOG    DS    FL1                 STACK DAMAGE INFORMATION             81300000
DSCLBIT  EQU   X'01'               LABELS CHANGED IN EDITING            81320000
DSMSBIT  EQU   X'02'               USER DESERVES A 'STACK DAMAGED' MSG  81340000
INTOG    DS    X                   FLAGS FOR INLINE SUBROUTINE          81360000
CEBIT    EQU   1                   CHARACTER-EDIT REQUEST FOR INLINE    81380000
ICVFG    DS    FL1                 NUMERIC INPUT CONVERSION FLAGS       81400000
QUADTOG  DS    FL1                 QUAD BITS FROM STFLAGS               81420000
WPAT     DS    CL9                 LINE NUMBER BUMPING WORKSPACE        81440000
EMAXIN   EQU   266                 MAXIMUM ALLOWABLE LINE LENGTH.  3574 81460000
         DS    H                   USED IN CHAR EDIT GAMES              81480000
*              INBUF-1 IS USED AS CHARACTER COUNT FOR CALL OF SQUIRTM.  81500000
INBUF    DS    (EMAXIN)C           SINK AREA FOR EDITED INPUT.     3574 81520000
*                     *******      SUPEREDIT MAY USE ANOTHER 154 BYTES  81540000
*                                  OR SO                                81560000
INBUFEND DS    1C                  BUCKET FOR CHAR PAST EMAXIN.    3574 81580000
MAXINSW  DS    FL1                 FF WHEN LINE PAST INBUF+EMAXIN  3574 81600000
MAXIN    DS    A                   ADDRESS OF INBUFEND.            3574 81620000
SVLKR    DS    A                   SAVEAREA FOR ILLEGAL CHAR PTR.  3574 81640000
PREPLEND EQU   *                                                        81660000
         COPY  DIRSECT                                                  81680000
         END                                                            81700000
./  ADD    NAME=APLSTRTA
TRTA     TITLE 'A P L   T R A N S L A T E   T A B L E S       05/11/70' 00150000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00300000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00450000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00600000
         MACRO                                                          00750000
&INT     TYOGN &EXT1,&EXT2                                              00900000
         GBLC  &TYOA,&TYOT,&TYIT                                        01050000
         GBLC  &GARB           TO GENERATE FAIL SAFE ORG CARDS          01200000
         LCLC  &A                                                       01350000
         ORG   &GARB                                                    01500000
.*       GENERATE TYO TRANSLATE TABLES                                  01650000
         ORG   &INT+&TYOA                                               01800000
         DC    X'&EXT1'                                                 01950000
         AIF ('&INT' NE 'ZUND').A2                                      02100000
.*       USE UNDERBAR VALUE                                             02250000
         ORG   &TYOT+ZAU                                                02400000
         DC    27X'&EXT1'                                               02550000
.A2      AIF   (T'&EXT2 EQ 'O').A1                                      02700000
.*   BACKSPACE AND OVERSTRIKE REQUIRED                                  02850000
         ORG   &INT+&TYOT                                               03000000
         DC    X'&EXT2'                                                 03150000
         MEXIT                                                          03300000
.A1      ORG   &TYIT+X'&EXT1'                                           03600000
         DC    AL1(&INT)                                                03750000
         AIF   ('&INT' EQ 'ZDELTA').A4                                  03900000
         AIF   (K'&INT NE 2).A3                                         04050000
&A       SETC  '&INT'(2,1)                                              04200000
         AIF   ('&A' LT '0').A4                                         04350000
.A3      MEXIT                                                          04500000
.A4      ORG   &TYOA+&INT.U                                             04650000
         DC    X'&EXT1'            DIERESIZED ALPHABET                  04800000
         MEND                                                           04950000
*                                                                       05100000
         MACRO                                                          05250000
         TYOTABG  &DEV                                                  05400000
         GBLC  &TYOA,&TYOT,&TYIT                                        05550000
         GBLC  &GARB           TO GENERATE FAIL SAFE ORG CARDS          05700000
&TYOT    SETC  'YO&DEV.TT'                                              05850000
&TYOA    SETC  'TYO&DEV'                                                06000000
&TYIT    SETC  'TYI&DEV'                                                06150000
&GARB    SETC  'FMRM&DEV'                                               06300000
         ORG                                                            06450000
         ENTRY &TYOA,&TYIT                                              06600000
&TYOA    DC    (ZLENGTH)C'Z'                                            06750000
&TYOT    DC    (ZLENGTH)X'00'                                           06900000
&TYIT    DC    256AL1(ZILG)                                             07050000
&GARB    DC    4AL1(ZILG)       THROWAWAY REGION                        07200000
         MEND                                                           07350000
*                                                                       07500000
         GBLC  &TYOA,&TYOT,&TYIT                                        07650000
         GBLB  &DIVA,&CP67                                              07800000
TRTABS   CSECT                                                          08250000
         PRINT OFF                 COPY ZSYMBOLS                        08400000
         COPY  ZSYMBOLS                                                 08550000
         TITLE 'A P L   T R A N S L A T E   T A B L E S       05/11/70' 08700000
         PRINT  ON                                                      08850000
         PRINT NOGEN                                                    09000000
TRTABS   CSECT                                                          09150000
         TITLE '1 0 5 2   T R A N S L A T E   T A B L E S     05/11/70' 09300000
*                                                                       22800000
         TYOTABG 1052              PHYSICIAL 1052-7                     22950000
ZILG     TYOGN 00                  BCD IDLE CHARACTER                   23100000
ZPFX     TYOGN 00                                                       23250000
ZFCOLON  TYOGN 4A                                                       23400000
ZFPER    TYOGN 4B                                                       23550000
ZALPHA   TYOGN C1                                                       23700000
ZAND     TYOGN 4F                                                       23850000
ZBASE    TYOGN C2                                                       24000000
ZBLANK   TYOGN 40                                                       24150000
ZBSLASH  TYOGN 6D                                                       24300000
ZCAP     TYOGN C3                                                       24450000
ZCIRCLE  TYOGN D6                                                       24600000
ZCOLBSLH TYOGN 6D,6E                                                    24750000
ZCOLON   TYOGN 4A                                                       24900000
ZCOLREV  TYOGN D6,6E                                                    25050000
ZCOLSLSH TYOGN 61,6E                                                    25200000
ZCOMMA   TYOGN 6B                                                       25350000
ZCR      TYOGN 15                                                       25500000
ZCUP     TYOGN E5                                                       25650000
ZDARROW  TYOGN E4                                                       25800000
ZDEL     TYOGN C7                                                       25950000
ZDELTA   TYOGN C8                                                       26100000
ZDIER    TYOGN 4D                                                       26250000
ZDIV     TYOGN 6C                                                       26400000
ZDNGRADE TYOGN C7,D4                                                    26550000
ZDOMINO  TYOGN D3,6C                                                    27150000
ZEOB     TYOGN 00                  1052-7 PSEUDO EOB                    27300000
ZEPS     TYOGN C5                                                       27450000
ZEQ      TYOGN 5D                                                       27600000
ZFE      TYOGN 85                                                       27750000
ZFOVB    TYOGN 4E                                                       27900000
ZGE      TYOGN 5E                                                       28050000
ZGT      TYOGN 5C                                                       28200000
ZHIST    TYOGN C2,D5                                                    28350000
ZIOTA    TYOGN C9                                                       28500000
ZLARROW  TYOGN 60                                                       28650000
ZLBR     TYOGN 5B                                                       28800000
ZLE      TYOGN 5F                                                       28950000
ZLOG     TYOGN D6,D7                                                    29100000
ZLPAR    TYOGN 5A                                                       29250000
ZLT      TYOGN 4C                                                       29400000
ZMAX     TYOGN E2                                                       29550000
ZMIN     TYOGN C4                                                       29700000
ZMINUS   TYOGN 6E                                                       29850000
ZMOD     TYOGN D4                                                       30000000
ZNAND    TYOGN 4F,E3                                                    30150000
ZNE      TYOGN 7D                                                       30300000
ZNOR     TYOGN 7F,E3                                                    30450000
ZNOT     TYOGN E3                                                       30600000
ZNULL    TYOGN D1                                                       30750000
ZOMEGA   TYOGN E6                                                       30900000
ZOR      TYOGN 7F                                                       31050000
ZOVB     TYOGN 4E                                                       31200000
ZPDEL    TYOGN C7,E3                                                    31350000
ZPER     TYOGN 4B                                                       31500000
ZPLUS    TYOGN 50                                                       31650000
ZQUAD    TYOGN D3                                                       31800000
ZQUADP   TYOGN D3,D2                                                    31950000
ZQUERY   TYOGN D8                                                       32100000
ZQUOTE   TYOGN D2                                                       32250000
ZRARROW  TYOGN 6F                                                       32400000
ZRBR     TYOGN 7B                                                       32550000
ZREM     TYOGN C3,D1                                                    32700000
ZREP     TYOGN D5                                                       32850000
ZREV     TYOGN D6,D4                                                    33000000
ZRHO     TYOGN D9                                                       33150000
ZRPAR    TYOGN 7E                                                       33300000
ZRSUB    TYOGN E7                  1052-7 -- PREMPTED                   33450000
ZSEMIC   TYOGN 7A                                                       33600000
ZSHRIEK  TYOGN D2,4B                                                    33750000
ZSLASH   TYOGN 61                                                       33900000
ZSTAR    TYOGN D7                                                       34050000
ZSUB     TYOGN E9                  1052-7 -- PREMPTED                   34200000
ZTIMES   TYOGN 7C                                                       34350000
ZTRAN    TYOGN 6D,D6                                                    34500000
ZUARROW  TYOGN E8                                                       34650000
ZUND     TYOGN C6                                                       34800000
ZUPGRADE TYOGN C8,D4                                                    34950000
ZBSUC    TYOGN E9                                                       35100000
ZBS      TYOGN E9  (16)            1052-7 FAKE BS -- U/C Z              35250000
ZLF      TYOGN E7  (25)            1052-7 PSEUDO LF -- U/C X            35400000
*        HANDLE ALPHABETS WITHOUT TYOGN                                 35700000
         ORG   &TYOA+Z0            HANDLE DIGITS                        35850000
         DC    C'0123456789'                                            36000000
         ORG   &TYOA+ZA            FIRST ALPHABET                       36150000
         DC    C'abcdefghijklmnopqrstuvwxyz'     LOWERCASE              36300000
         ORG   &TYOA+ZAU           SECOND ALPHABET                      36450000
         DC    C'abcdefghijklmnopqrstuvwxyz'     LOWERCASE              36600000
         ORG   &TYIT+C'A'-X'40'                                         36750000
         DC    AL1(ZA,ZB,ZC,ZD,ZE,ZF,ZG,ZH,ZI)                          36900000
         ORG   &TYIT+C'J'-X'40'                                         37050000
         DC    AL1(ZJ,ZK,ZL,ZM,ZN,ZO,ZP,ZQ,ZR)                          37200000
         ORG   &TYIT+C'S'-X'40'                                         37350000
         DC    AL1(ZS,ZT,ZU,ZV,ZW,ZX,ZY,ZZ)                             37500000
         ORG   &TYIT+C'0'                                               37650000
         DC    AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9)                       37800000
         TITLE '1 0 5 0   T R A N S L A T E   T A B L E S     05/11/70' 37950000
*                                                                       38100000
         TYOTABG 1050                                                   38250000
ZHIST    TYOGN CA,E4                                                    38400000
ZREM     TYOGN E7,C3              ZCAP,ZNULL                            38550000
ZREV     TYOGN CC,C9                                                    38700000
ZSHRIEK  TYOGN 76,C5                                                    38850000
ZQUADP   TYOGN C6,C5                                                    39000000
ZTRAN    TYOGN CC,A3                                                    39150000
ZLOG     TYOGN CC,CF                                                    39300000
ZNAND    TYOGN 95,A6                                                    39450000
ZNOR     TYOGN 93,A6                                                    39600000
ZPDEL    TYOGN EE,A6                                                    39750000
ZCOLREV  TYOGN CC,C0                                                    39900000
ZCOLSLSH TYOGN 23,C0                                                    40050000
ZCOLBSLH TYOGN A3,C0                                                    40200000
ZUPGRADE TYOGN F0,C9                                                    40350000
ZDNGRADE TYOGN EE,C9                                                    40500000
ZDOMINO  TYOGN C6,E1                                                    40650000
ZILG     TYOGN FF                  BCD IDLE CHARACTER                   41250000
ZFPER    TYOGN 76                                                       41400000
ZFCOLON  TYOGN F6                                                       41550000
Z1       TYOGN 02                                                       41700000
Z2       TYOGN 04                                                       41850000
Z3       TYOGN 07                                                       42000000
Z4       TYOGN 08                                                       42150000
Z5       TYOGN 0B                                                       42300000
Z6       TYOGN 0D                                                       42450000
Z7       TYOGN 0E                                                       42600000
Z8       TYOGN 10                                                       42750000
Z9       TYOGN 13                                                       42900000
Z0       TYOGN 15                                                       43050000
ZRBR     TYOGN 16                                                       43200000
ZEOB     TYOGN 1F                  CRC ON INPUT OK                      43350000
ZLARROW  TYOGN 20                                                       43500000
ZSLASH   TYOGN 23                                                       43650000
ZS       TYOGN 25                                                       43800000
ZT       TYOGN 26                                                       43950000
ZU       TYOGN 29                                                       44100000
ZV       TYOGN 2A                                                       44250000
ZW       TYOGN 2C                                                       44400000
ZX       TYOGN 2F                                                       44550000
ZY       TYOGN 31                                                       44700000
ZZ       TYOGN 32                                                       44850000
ZCOMMA   TYOGN 37                                                       45000000
ZLF      TYOGN 3B                                                       45150000
ZPLUS    TYOGN 40                                                       45300000
ZJ       TYOGN 43                                                       45450000
ZK       TYOGN 45                                                       45600000
ZL       TYOGN 46                                                       45750000
ZM       TYOGN 49                                                       45900000
ZN       TYOGN 4A                                                       46050000
ZO       TYOGN 4C                                                       46200000
ZP       TYOGN 4F                                                       46350000
ZQ       TYOGN 51                                                       46500000
ZR       TYOGN 52                                                       46650000
ZLBR     TYOGN 57                                                       46800000
ZCR      TYOGN DB                                                       46950000
ZBSUC    TYOGN DD                                                       47100000
ZBS      TYOGN DD                                                       47250000
ZBS      TYOGN 5D                                                       47400000
ZTIMES   TYOGN 61                                                       47550000
ZA       TYOGN 62                                                       47700000
ZB       TYOGN 64                                                       47850000
ZC       TYOGN 67                                                       48000000
ZD       TYOGN 68                                                       48150000
ZFE      TYOGN 6B                 FAKE E                                48300000
ZE       TYOGN 6B                                                       48450000
ZF       TYOGN 6D                                                       48600000
ZG       TYOGN 6E                                                       48750000
ZH       TYOGN 70                                                       48900000
ZI       TYOGN 73                                                       49050000
ZPER     TYOGN 76                                                       49200000
ZBLANK   TYOGN 7A                                                       49350000
ZBLANK   TYOGN 81                                                       49500000
ZDIER    TYOGN 82                                                       49650000
ZFOVB    TYOGN 84                 FAKE OVERBAR                          49800000
ZOVB     TYOGN 84                                                       49950000
ZLT      TYOGN 87                                                       50100000
ZLE      TYOGN 88                                                       50250000
ZEQ      TYOGN 8B                                                       50400000
ZGE      TYOGN 8D                                                       50550000
ZGT      TYOGN 8E                                                       50700000
ZNE      TYOGN 90                                                       50850000
ZOR      TYOGN 93                                                       51000000
ZAND     TYOGN 95                                                       51150000
ZRPAR    TYOGN 96                                                       51300000
ZEOB     TYOGN 9F                  CRC ON INPUT OK                      51450000
ZRARROW  TYOGN A0                                                       51600000
ZBSLASH  TYOGN A3                                                       51750000
ZMAX     TYOGN A5                                                       51900000
ZNOT     TYOGN A6                                                       52050000
ZDARROW  TYOGN A9                                                       52200000
ZCUP     TYOGN AA                                                       52350000
ZOMEGA   TYOGN AC                                                       52500000
ZRSUB    TYOGN AF                                                       52650000
ZUARROW  TYOGN B1                                                       52800000
ZSUB     TYOGN B2                                                       52950000
ZSEMIC   TYOGN B7                                                       53100000
ZLF      TYOGN BB                                                       53250000
ZEOB     TYOGN BD                                                       53400000
ZMINUS   TYOGN C0                                                       53550000
ZNULL    TYOGN C3                                                       53700000
ZQUOTE   TYOGN C5                                                       53850000
ZQUAD    TYOGN C6                                                       54000000
ZMOD     TYOGN C9                                                       54150000
ZREP     TYOGN CA                                                       54300000
ZCIRCLE  TYOGN CC                                                       54450000
ZSTAR    TYOGN CF                                                       54600000
ZQUERY   TYOGN D1                                                       54750000
ZRHO     TYOGN D2                                                       54900000
ZLPAR    TYOGN D7                                                       55050000
ZCR      TYOGN 5B                                                       55200000
ZDIV     TYOGN E1                                                       55350000
ZALPHA   TYOGN E2                                                       55500000
ZBASE    TYOGN E4                                                       55650000
ZCAP     TYOGN E7                                                       55800000
ZMIN     TYOGN E8                                                       55950000
ZEPS     TYOGN EB                                                       56100000
ZUND     TYOGN ED                                                       56250000
ZDEL     TYOGN EE                                                       56400000
ZDELTA   TYOGN F0                                                       56550000
ZIOTA    TYOGN F3                                                       56700000
ZCOLON   TYOGN F6                                                       56850000
ZBLANK   TYOGN FA                                                       57000000
ZBLANK   TYOGN 01                                                       57150000
ZEOB     TYOGN 3D                                                       57300000
*                                                                       57450000
         ORG   TYO1050+ZEOB                                             57600000
         DC    X'3D'               MAKE SURE REAL EOB IS USED ON OUTPUT 57750000
*                                                                       57900000
ZPFX     TYOGN 3E                                                       58050000
         ORG   TYI1050+X'3E'                                            58200000
         DC    AL1(ZILG)           DON'T ALLOW PFX ON INPUT             58350000
         TITLE 'T S 4 1   T R A N S L A T E   T A B L E S     05/11/70' 58500000
*                                                                       58650000
         TYOTABG TS41    TSS 2741 CHARACTER SET                         58800000
ZHIST    TYOGN CA,E4                                                    58950000
ZREM     TYOGN E7,C3              ZCAP,ZNULL                            59100000
ZREV     TYOGN CC,C9                                                    59250000
ZSHRIEK  TYOGN 76,C5                                                    59400000
ZQUADP   TYOGN C6,C5                                                    59550000
ZTRAN    TYOGN CC,A3                                                    59700000
ZLOG     TYOGN CC,CF                                                    59850000
ZNAND    TYOGN 95,A6                                                    60000000
ZNOR     TYOGN 93,A6                                                    60150000
ZPDEL    TYOGN EE,A6                                                    60300000
ZCOLREV  TYOGN CC,C0                                                    60450000
ZCOLSLSH TYOGN 23,C0                                                    60600000
ZCOLBSLH TYOGN A3,C0                                                    60750000
ZUPGRADE TYOGN F0,C9                                                    60900000
ZDNGRADE TYOGN EE,C9                                                    61050000
ZDOMINO  TYOGN C6,E1                                                    61200000
ZILG     TYOGN FF                  BCD IDLE CHARACTER                   61800000
ZFPER    TYOGN 76                                                       61950000
ZFCOLON  TYOGN F6                                                       62100000
Z1       TYOGN 02                                                       62250000
Z2       TYOGN 04                                                       62400000
Z3       TYOGN 07                                                       62550000
Z4       TYOGN 08                                                       62700000
Z5       TYOGN 0B                                                       62850000
Z6       TYOGN 0D                                                       63000000
Z7       TYOGN 0E                                                       63150000
Z8       TYOGN 10                                                       63300000
Z9       TYOGN 13                                                       63450000
Z0       TYOGN 15                                                       63600000
ZRBR     TYOGN 16                                                       63750000
ZEOB     TYOGN 1F                  CRC ON INPUT OK                      63900000
ZLARROW  TYOGN 20                                                       64050000
ZSLASH   TYOGN 23                                                       64200000
ZS       TYOGN 25                                                       64350000
ZT       TYOGN 26                                                       64500000
ZU       TYOGN 29                                                       64650000
ZV       TYOGN 2A                                                       64800000
ZW       TYOGN 2C                                                       64950000
ZX       TYOGN 2F                                                       65100000
ZY       TYOGN 31                                                       65250000
ZZ       TYOGN 32                                                       65400000
ZCOMMA   TYOGN 37                                                       65550000
ZLF      TYOGN 3B                                                       65700000
ZPLUS    TYOGN 40                                                       65850000
ZJ       TYOGN 43                                                       66000000
ZK       TYOGN 45                                                       66150000
ZL       TYOGN 46                                                       66300000
ZM       TYOGN 49                                                       66450000
ZN       TYOGN 4A                                                       66600000
ZO       TYOGN 4C                                                       66750000
ZP       TYOGN 4F                                                       66900000
ZQ       TYOGN 51                                                       67050000
ZR       TYOGN 52                                                       67200000
ZLBR     TYOGN 57                                                       67350000
ZBSUC    TYOGN DD                                                       67500000
ZBS      TYOGN DD                                                       67650000
ZBS      TYOGN 5D                                                       67800000
ZTIMES   TYOGN 61                                                       67950000
ZA       TYOGN 62                                                       68100000
ZB       TYOGN 64                                                       68250000
ZC       TYOGN 67                                                       68400000
ZD       TYOGN 68                                                       68550000
ZFE      TYOGN 6B                 FAKE E                                68700000
ZE       TYOGN 6B                                                       68850000
ZF       TYOGN 6D                                                       69000000
ZG       TYOGN 6E                                                       69150000
ZH       TYOGN 70                                                       69300000
ZI       TYOGN 73                                                       69450000
ZPER     TYOGN 76                                                       69600000
ZBLANK   TYOGN 7A                                                       69750000
ZBLANK   TYOGN 81                                                       69900000
ZDIER    TYOGN 82                                                       70050000
ZFOVB    TYOGN 84                  FAKE OVERBAR                         70200000
ZOVB     TYOGN 84                                                       70350000
ZLT      TYOGN 87                                                       70500000
ZLE      TYOGN 88                                                       70650000
ZEQ      TYOGN 8B                                                       70800000
ZGE      TYOGN 8D                                                       70950000
ZGT      TYOGN 8E                                                       71100000
ZNE      TYOGN 90                                                       71250000
ZOR      TYOGN 93                                                       71400000
ZAND     TYOGN 95                                                       71550000
ZRPAR    TYOGN 96                                                       71700000
ZEOB     TYOGN 9F                  CRC ON INPUT OK                      71850000
ZRARROW  TYOGN A0                                                       72000000
ZBSLASH  TYOGN A3                                                       72150000
ZMAX     TYOGN A5                                                       72300000
ZNOT     TYOGN A6                                                       72450000
ZDARROW  TYOGN A9                                                       72600000
ZCUP     TYOGN AA                                                       72750000
ZOMEGA   TYOGN AC                                                       72900000
ZRSUB    TYOGN AF                                                       73050000
ZUARROW  TYOGN B1                                                       73200000
ZSUB     TYOGN B2                                                       73350000
ZSEMIC   TYOGN B7                                                       73500000
ZLF      TYOGN BB                                                       73650000
ZMINUS   TYOGN C0                                                       73800000
ZNULL    TYOGN C3                                                       73950000
ZQUOTE   TYOGN C5                                                       74100000
ZQUAD    TYOGN C6                                                       74250000
ZMOD     TYOGN C9                                                       74400000
ZREP     TYOGN CA                                                       74550000
ZCIRCLE  TYOGN CC                                                       74700000
ZSTAR    TYOGN CF                                                       74850000
ZQUERY   TYOGN D1                                                       75000000
ZRHO     TYOGN D2                                                       75150000
ZLPAR    TYOGN D7                                                       75300000
ZCR      TYOGN DB                                                       75450000
ZCR      TYOGN 5B                                                       75600000
ZDIV     TYOGN E1                                                       75750000
ZALPHA   TYOGN E2                                                       75900000
ZBASE    TYOGN E4                                                       76050000
ZCAP     TYOGN E7                                                       76200000
ZMIN     TYOGN E8                                                       76350000
ZEPS     TYOGN EB                                                       76500000
ZUND     TYOGN ED                                                       76650000
ZDEL     TYOGN EE                                                       76800000
ZDELTA   TYOGN F0                                                       76950000
ZIOTA    TYOGN F3                                                       77100000
ZCOLON   TYOGN F6                                                       77250000
ZBLANK   TYOGN FA                                                       77400000
ZBLANK   TYOGN 01                                                       77550000
ZEOB     TYOGN 3D                  CRB ON INPUT OK                      77700000
ZEOB     TYOGN BD                  CRB ON INPUT OK                      77850000
ZPFX     TYOGN BE                                                       78000000
ZPFX     TYOGN 3E                                                       78150000
*                                                                       78300000
         ORG   TYOTS41+ZEOB                                             78450000
         DC    X'7F'               BCD IDLE CHAR                        78600000
         TITLE '2 7 4 1   T R A N S L A T E   T A B L E S     05/11/70' 78750000
*                                                                       78900000
         TYOTABG 2741       GENUINE 2741 CHARACTER SET                  79050000
ZFOVB    TYOGN 84                                                       79200000
ZFE      TYOGN 29                                                       79350000
ZFPER    TYOGN 45                                                       79500000
ZFCOLON  TYOGN C5                                                       79650000
ZHIST    TYOGN B7,A5                                                    79800000
ZLOG     TYOGN D1,E8                                                    79950000
ZNAND    TYOGN 93,A0                                                    80100000
ZNOR     TYOGN 96,A0                                                    80250000
ZQUADP   TYOGN B1,AC                                                    80400000
ZREM     TYOGN AF,E1              ZCAP,ZNULL                            80550000
ZREV     TYOGN D1,C3                                                    80700000
ZSHRIEK  TYOGN AC,45                                                    80850000
ZTRAN    TYOGN D1,F0                                                    81000000
ZPDEL    TYOGN E2,A0                                                    81150000
ZCOLREV  TYOGN D1,F6                                                    81300000
ZCOLSLSH TYOGN 70,F6                                                    81450000
ZCOLBSLH TYOGN F0,F6                                                    81600000
ZUPGRADE TYOGN B2,C3                                                    81750000
ZDNGRADE TYOGN E2,C3                                                    81900000
ZDOMINO  TYOGN B1,E4                                                    82050000
ZILG     TYOGN FF                  BCD IDLE CHARACTER                   82650000
ZA       TYOGN 4F                                                       82800000
ZB       TYOGN 37                                                       82950000
ZC       TYOGN 2F                                                       83100000
ZD       TYOGN 2A                                                       83250000
ZE       TYOGN 29                                                       83400000
ZF       TYOGN 67                                                       83550000
ZG       TYOGN 62                                                       83700000
ZH       TYOGN 32                                                       83850000
ZI       TYOGN 4C                                                       84000000
ZJ       TYOGN 61                                                       84150000
ZK       TYOGN 2C                                                       84300000
ZL       TYOGN 31                                                       84450000
ZM       TYOGN 43                                                       84600000
ZN       TYOGN 25                                                       84750000
ZO       TYOGN 51                                                       84900000
ZP       TYOGN 68                                                       85050000
ZQ       TYOGN 6D                                                       85200000
ZR       TYOGN 4A                                                       85350000
ZS       TYOGN 52                                                       85500000
ZT       TYOGN 20                                                       85650000
ZU       TYOGN 26                                                       85800000
ZV       TYOGN 46                                                       85950000
ZW       TYOGN 57                                                       86100000
ZX       TYOGN 23                                                       86250000
ZY       TYOGN 73                                                       86400000
ZZ       TYOGN 15                                                       86550000
Z0       TYOGN 13                                                       86700000
Z1       TYOGN 02                                                       86850000
Z2       TYOGN 04                                                       87000000
Z3       TYOGN 07                                                       87150000
Z4       TYOGN 10                                                       87300000
Z5       TYOGN 08                                                       87450000
Z6       TYOGN 0D                                                       87600000
Z7       TYOGN 0B                                                       87750000
Z8       TYOGN 0E                                                       87900000
Z9       TYOGN 16                                                       88050000
ZALPHA   TYOGN CF                                                       88200000
ZBASE    TYOGN B7                                                       88350000
ZCAP     TYOGN AF                                                       88500000
ZMIN     TYOGN AA                                                       88650000
ZEPS     TYOGN A9                                                       88800000
ZUND     TYOGN E7                                                       88950000
ZDEL     TYOGN E2                                                       89100000
ZDELTA   TYOGN B2                                                       89250000
ZIOTA    TYOGN CC                                                       89400000
ZNULL    TYOGN E1                                                       89550000
ZQUOTE   TYOGN AC                                                       89700000
ZQUAD    TYOGN B1                                                       89850000
ZMOD     TYOGN C3                                                       90000000
ZREP     TYOGN A5                                                       90150000
ZCIRCLE  TYOGN D1                                                       90300000
ZSTAR    TYOGN E8                                                       90450000
ZQUERY   TYOGN ED                                                       90600000
ZRHO     TYOGN CA                                                       90750000
ZMAX     TYOGN D2                                                       90900000
ZNOT     TYOGN A0                                                       91050000
ZDARROW  TYOGN A6                                                       91200000
ZCUP     TYOGN C6                                                       91350000
ZOMEGA   TYOGN D7                                                       91500000
ZRSUB    TYOGN A3                                                       91650000
ZUARROW  TYOGN F3                                                       91800000
ZSUB     TYOGN 95                                                       91950000
ZLARROW  TYOGN 40                                                       92100000
ZRBR     TYOGN 49                                                       92250000
ZTIMES   TYOGN 64                                                       92400000
ZLBR     TYOGN 6B                                                       92550000
ZCOMMA   TYOGN 6E                                                       92700000
ZSEMIC   TYOGN EE                                                       92850000
ZPER     TYOGN 45                                                       93000000
ZCOLON   TYOGN C5                                                       93150000
ZSLASH   TYOGN 70                                                       93300000
ZPLUS    TYOGN 76                                                       93450000
ZDIER    TYOGN 82                                                       93600000
ZOVB     TYOGN 84                                                       93750000
ZLT      TYOGN 87                                                       93900000
ZEQ      TYOGN 88                                                       94050000
ZGT      TYOGN 8B                                                       94200000
ZGE      TYOGN 8D                                                       94350000
ZNE      TYOGN 8E                                                       94500000
ZLE      TYOGN 90                                                       94650000
ZAND     TYOGN 93                                                       94800000
ZOR      TYOGN 96                                                       94950000
ZRARROW  TYOGN C0                                                       95100000
ZRPAR    TYOGN C9                                                       95250000
ZDIV     TYOGN E4                                                       95400000
ZLPAR    TYOGN EB                                                       95550000
ZBSLASH  TYOGN F0                                                       95700000
ZMINUS   TYOGN F6                                                       95850000
ZLF      TYOGN 3B                                                       96000000
ZLF      TYOGN BB                                                       96150000
ZCR      TYOGN DB                                                       96300000
ZCR      TYOGN 5B                                                       96450000
ZBSUC    TYOGN DD                                                       96600000
ZBS      TYOGN DD                                                       96750000
ZBS      TYOGN 5D                                                       96900000
ZBLANK   TYOGN 7A                                                       97050000
ZBLANK   TYOGN FA                                                       97200000
ZEOB     TYOGN 9F                                                       97350000
ZEOB     TYOGN 1F                                                       97500000
ZEOB     TYOGN 3D                  CRB ON INPUT OK                      97650000
ZEOB     TYOGN BD                  CRB ON INPUT OK                      97800000
ZPFX     TYOGN BE                                                       97950000
ZPFX     TYOGN 3E                                                       98100000
ZBLANK   TYOGN 81                                                       98250000
ZBLANK   TYOGN 01                                                       98400000
         ORG   TYO2741+ZEOB                                             98550000
         DC    X'7F'               BCD IDLE CHAR                        98700000
         ORG                                                            98850000
         END                                                            99000000
./  ADD    NAME=APLSVDOP
VDOP     TITLE 'VARIABLE DIMENSION OPERATORS                  05/11/70' 00080000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00160000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00240000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00320000
         PRINT OFF       APLDEFN, ZSYMBOLS, OPSECT                      00480000
VDOP     CSECT                                                          00560000
         COPY  APLDEFN                                                  00640000
         COPY ZSYMBOLS                                                  00720000
         COPY OPSECT                                                    00800000
         TITLE 'VARIABLE DIMENSION OPERATORS                  05/11/70' 00880000
         PRINT ON,NOGEN,NODATA                                          00960000
VDOP     CSECT                                                          01040000
         EXTRN ARTHTP                                                   01120000
         EXTRN BLOWRTN                                                  01200000
         EXTRN ERROR                                                    01280000
         EXTRN FETCH                                                    01360000
         EXTRN FETCHINT                                                 01440000
         EXTRN IDENTS                                                   01520000
         EXTRN MBLOWRTN                                                 01600000
         EXTRN OPSPACE                                                  01680000
         EXTRN OPTAG                                                    01760000
         ENTRY EXBASE                                                   01840000
         ENTRY EXREP                                                    01920000
         ENTRY MATRIX                                                   02000000
         ENTRY REDUCE                                                   02080000
         USING OPSECT-16,13                                             02160000
AX       EQU   8                                                        02240000
BX       EQU   7                                                        02320000
ZXR      EQU   6                                                        02400000
         EJECT                                                          02480000
         USING *,9                                                      02560000
MATRIX   ST    12,CALLBASE         SAVE THE CALLING ROUTINE BASE REG    02640000
         DROP  9                                                        02720000
         BALR  12,0                                                     02800000
         USING *,12                                                     02880000
         ST    LKR,RREG                                                 02960000
         LA    14,(LEND-OPSECT+7)/8*8+16(,13)                      P052 03040000
*                                                                       03120000
*                                                                       03200000
PROD     SR    ZXR,ZXR                                                  03280000
         ST    ZXR,RPTEST          THIS IS MATRIX PRODUCT               03360000
         SR    1,1                 CHECK RIGHT OPERATOR                 03440000
         IC    1,OPERATOR+3                                             03520000
         A     1,=A(OPTAG)                                              03600000
         TM    1(1),1              IS RIGHT OP SCALAR?                  03680000
         BZ    SYNTERR             NO                                   03760000
*                                  DETERMINE GOOD STUFF ABOUT LEFT OPE  03840000
         LR    0,ZXR               A ZERO                               03920000
         LR    1,ZXR                                                    04000000
         CLI   INDBASE,0           IS AN INDEX SPECIFIED ?              04080000
         BNZ   SYNTERR             YES                                  04160000
         ST    ZXR,OUT             ASSUME OUTER PRODUCT                 04240000
         CLI   OPERATOR+2,1+2*ZNULL   IS IT ?                           04320000
         BNE   PROD3               NO USE INNER                         04400000
         LM    1,5,TYPINFO         AVOID CONSTANT NEED TO CHECK FOR     04480000
         B     PROD5               INNER OR OUTER                       04560000
PROD3    MVC   OUT,=F'4'           MARK IT INNER PRODUCT                04640000
         IC    1,OPERATOR+2                                             04720000
         A     1,=A(OPTAG)                                              04800000
         TM    1(1),1              IS OP1 SCALAR ?                      04880000
         BZ    SYNTERR             NO                                   04960000
         LR    1,ZXR                                                    05040000
         IC    1,OPERATOR+2        GET GOOD STUFF ABOUT LEFT OPER       05120000
         L     2,RSTYPE                                                 05200000
         LR    3,2                                                      05280000
         ICALL ARTHTP                                                   05360000
PROD5    STM   1,5,AOP1                                                 05440000
*                                                                       05520000
*                                                                       05600000
*                                                                       05680000
DOPROD   BAL   LKR,CONFORM                                              05760000
         B     FILL                    CONFORM FOUND EMPTY RESULT OR    05840000
*                                      FILLED WITH AN IDENTITY ELEMENT  05920000
         MVC   CALC1,BALIN                                              06000000
*                                  ASSUME NO CONVERSION                 06080000
*                                  NEEDED FROM OP2 RESULT               06160000
         MVC   INCSTP(2),BRZXR     TO OP1 ARG TYPE                      06240000
*                                  GEE WHERE HAVE I SEEN THIS BEFORE    06320000
         L     1,RTYPE                                                  06400000
         SLA   1,2                 GET CODE TO CONVERT LEFT OP RESULT   06480000
         A     1,OP1CTP            TO LEFT OP ARG TYPE.                 06560000
         IC    1,FTCHTYP-5(1)                                           06640000
         ST    1,RTOSCODE          CONVERSION NOT DONE UNLESS NEEDED    06720000
DOPROD7  MVC   CALC2,BINFOP1       ASSUME INNER LOOP IS FLOATING        06800000
         CLI   OP1CTP+3,3          GOOD GUESS ?                         06880000
         BE    DOPROD11            YES                                  06960000
         MVC   CALC2,BINIOP1       NO MAKE IT FIXED                     07040000
*                                                                       07120000
DOPROD11 BAL   LKR,SETSTORE        SET UP RESULT STORE                  07200000
         ON    XOF,BLOW            ENABLE FIXED OVERFLOW                07280000
         CLI   OUT+3,0             IS THIS OUTER PROD ?                 07360000
         BNZ   DOPROD13            NO                                   07440000
         BAL   LKR,ALTER1                                               07520000
         L     5,ZPT               RESULT STARTS AT RIGHT               07600000
OUTL1    L     BX,BRT              B STARTS AT RIGHT                    07680000
OUTL3    C     BX,LASTB            DONE WITH ELE OF A                   07760000
         BE    OUTL7               YES                                  07840000
         S     BX,LB               NO,MOVE TO NEXT ELE OF B             07920000
         EX    0,CALC1                                                  08000000
         LR    9,5                                                      08080000
         EX    0,SRESULT           STORE RESULT                         08160000
         S     5,LZ                MOVE TO NEXT ELEMENT OF Z            08240000
         QUEND                                                          08320000
         B     OUTL3                                                    08400000
OUTL7    S     AX,AINC             MOVE TO NEXT ELEMENT OF A            08480000
         C     5,LASTZ             ALL DONE ?                           08560000
         BNL   OUTL1                                                    08640000
         B     DOEND                                                    08720000
DOPROD13 BAL   LKR,ALTER                                                08800000
*                                  WORRY ABOUT CONVERTING THE           08880000
*                                  RESULT OF SCAN OPERATOR BACK TO      08960000
*                                  THE ARG TYPE OF THE SCAN             09040000
         MVC   INCSTS,BLOOP5                                            09120000
         CLC   RTYPE+3(1),OP1CTP+3  IS CONVERSION NEEDED                09200000
         BE    DOPROD14            NO                                   09280000
         MVC   INCSTS(2),NOP       IT IS                                09360000
DOPROD14 CLC   OP1CTP+3(1),RSTYPE+3                                     09440000
         BE    DOPROD15            YES                                  09520000
         CLC   SD,=F'1'            IF SCAN IS OVER ONE COMPONENT,       09600000
*                                  THEN NO CONVERSION TO SCAN ARG       09680000
*                                  TYPE NO MATTER WHAT THE OP IS        09760000
         BE    DOPROD15                                                 09840000
         MVC   INCSTP,BINCSTP1     WIN ONE,LOSE ONE                     09920000
*                                  SAVE LEFT OPERAND                    10000000
         MVC   PTOSCODE,OP1LFC     FETCH CODE                           10080000
DOPROD15 B     OLOOP               OFF TO COMMON OUTER LOOP             10160000
DOEND    L     LKR,RREG                                                 10240000
         ON    XOF                 DISABLE FIXED OVERFLOW               10320000
         ON    XDZ                 DISABLE FIXED DIVISION BY ZERO       10400000
         L     12,CALLBASE                                              10480000
         BR    LKR                                                      10560000
*                                                                       10640000
*                                                                       10720000
*              INNER AND OUTER PRODUCT INITIAL VALUE ROUTINES           10800000
*                                                                       10880000
*              EX  0,INCSTP   CONVERTS RESULT OF OP1 TO ARG TYPE OF     10960000
*              SCAN                                                     11040000
*                                                                       11120000
*              MATRIX PRODUCT INITIAL VALUE ROUTINE                     11200000
IN       EX    0,AGET              GET ELEMENT OF A INTO R1 OR F0       11280000
         EX    0,BGET              GET ELEMENT OF B INTO R2 OR F2       11360000
         L     9,OPRN                                                   11440000
         BALR  LKR,9               EXECUTE THE OPERATOR  (WHAT ELSE)    11520000
         EX    0,INCSTP                                                 11600000
*                                                                       11680000
*                                                                       11760000
*              CONVERT OP2 RESULT TO OP1 ARG TYPE                       11840000
*              GETD WILL RETURN TO ADDRESS IN LINKS                     11920000
INCSTP1  ST    1,PRESULT           STORE INTEGER RESULT                 12000000
         ST    ZXR,LINKS            RETURN FROM GETD                    12080000
         MVC   CCODE,PTOSCODE                                           12160000
         CLI   RSTYPE+3,3                                               12240000
         BNE   GETD                CONVERT IT                           12320000
         STD   0,PRESULT           STORE FLOATING RESULT                12400000
         B     GETD                CONVERT IT                           12480000
*                                                                       12560000
*                                                                       12640000
*               FLOATING INNER LOOP FOR MATRIX PRODUCT                  12720000
INFOP1   S     AX,TAR              MOVE TO NEXT ELEMENT OF A            12800000
         STD   0,TPROD             SAVE RESULT OF SCAN SO FAR           12880000
         EX    0,CALC1             FORM NEXT PRODUCT                    12960000
*              LEFT OPERAND ALL SET UP                                  13040000
         LD    2,TPROD             RIGHT OPERAND                        13120000
INFOP11  L     9,AOP1                                                   13200000
         BALR  LKR,9               EXECUTE THE SCAN OPERATOR            13280000
         BCT   5,INFOP15           THIS THE LAST PARTIAL RESULT ?       13360000
         B     LOOP6               YES - DON'T BOTHER TO                13440000
*                                  CHECK FOR CONVERSION                 13520000
INFOP15  EX    0,INCSTS                  CONVERSION NEEDED ?            13600000
*                                       ONLY LOGICAL OPERATORS COULD NE 13680000
         ST    1,PRESULT                                                13760000
         MVC   CCODE,RTOSCODE                                           13840000
         MVC   LINKS,=A(LOOP5)     SET GETD RETURN ADDRESS              13920000
         B     GETD                                                     14000000
*                                                                       14080000
*                                                                       14160000
*              FIXED INNER LOOP FOR MATRIX PRODUCT                      14240000
INIOP1   S     AX,TAR              MOVE TO NEXT ELEMENT OF A            14320000
         ST    1,TPROD             SAVE RESULT OF SCAN SO FAR           14400000
         EX    0,CALC1             FORM NEXT PRODUCT                    14480000
*                                  LEFT OPERAND ALL SET UP              14560000
         L     2,TPROD             RIGHT OPERAND                        14640000
         B     INFOP11             REST SAME AS FLOATING                14720000
*                                                                       14800000
*                                                                       14880000
BALIN    BAL   ZXR,IN                   MATRIX PROD INITIAL VAL ROUTINE 14960000
BLOOP5   B     LOOP5                                                    15040000
*                                                                       15120000
*              INNER LOOP CALC  (CALC2)                                 15200000
BINFOP1  B     INFOP1              FLOATING INNER LOOP                  15280000
BINIOP1  B     INIOP1              INTEGER INNER LOOP                   15360000
*                                                                       15440000
*                                                                       15520000
BINCSTP1 B     INCSTP1             CONVERT SCAN RESULT TO PRODUCT       15600000
FTCHTYP  DC    FL1'1,5,6,13,7,2,8,13,9,10,3,13,13,13,13,4'              15680000
         EJECT                                                          15760000
         USING *,9                                                      15840000
EXBASE   ST    12,CALLBASE         SAVE THE CALLING ROUTINE BASE REG    15920000
         L     12,=A(MATRIX+6)                                          16000000
         DROP  9                                                        16080000
         ST    LKR,RREG                                                 16160000
         LA    14,(LEND-OPSECT+7)/8*8+16(,13)                      P052 16240000
*                                                                       16320000
*                                                                       16400000
BASEV    SR    ZXR,ZXR                                                  16480000
         LA    1,1                                                      16560000
         ST    1,RPTEST            IN CASE SPECIAL IDENTITY ELE NEEDED  16640000
         MVC   RTYPE,RSTYPE        FOR COMPATIBILITY WITH MATRIX PRODU  16720000
         MVC   OUT,=F'4'           IS BASE VALUE                        16800000
DOBASE   BAL   LKR,CONFORM                                              16880000
         B     FILL                    CONFORM FOUND EMPTY RESULT OR    16960000
*                                      FILLED RESULT WITH IDENTITY ELE  17040000
         MVC   CALC1,BALBASE                                            17120000
         MVC   CALC2,BBALOOPF      ASSUME FLOATING INNER LOOP           17200000
         CLI   COMTYP+3,3          GOOD GUESS ?                         17280000
         BE    DOB1                YES                                  17360000
         MVC   CALC2,BBALOOPI      NO, MAKE IT FIXED                    17440000
DOB1     BAL   LKR,SETSTORE        SET UP RESULT STORE                  17520000
         ON    XOF,BLOW            ENABLE FIXED OVERFLOW                17600000
         BAL   LKR,ALTER                                                17680000
         LM    2,3,TBR1            GET SBR AND TBR1                     17760000
         L     BX,BRT                                                   17840000
         SR    BX,3                WE DO BASE FROM LEFT TO RIGHT        17920000
         AR    BX,2                POINTS ONE TOO HIGH                  18000000
         LCR   2,2                 NEGATE TBR1                          18080000
         LCR   3,3                 NEGATE SBR                           18160000
         LR    1,3                 RECALCULATE SBRM1 NOW IT IS          18240000
         S     1,LB                - ( SBR+1 ) COLS GO IN USUAL ORDER   18320000
         ST    1,SBRM1                                                  18400000
         STM   2,3,TBR1                                                 18480000
         S     AX,AINC                                                  18560000
         A     AX,LA                                                    18640000
         ST    AX,APT1                                                  18720000
DOB2     B     OLOOP                                                    18800000
         EJECT                                                          18880000
         USING *,9                                                      18960000
EXREP    ST    12,CALLBASE         SAVE THE CALLING ROUTINE BASE REG    19040000
         L     12,=A(MATRIX+6)                                          19120000
         DROP  9                                                        19200000
         ST    LKR,RREG                                                 19280000
         LA    14,(LEND-OPSECT+7)/8*8+16(,13)                      P052 19360000
*                                                                       19440000
*                                                                       19520000
REP      SR    ZXR,ZXR                                                  19600000
         LA    1,1                                                      19680000
         ST    1,RPTEST            THIS IS REPRESENT                    19760000
         MVC   RTYPE,RSTYPE        FOR COMPATIBILITY WITH MATRIX PRODU  19840000
*                                  R0 = 0 FROM LOCATE                   19920000
         ST    0,OUT                                                    20000000
DOREP    BAL   LKR,CONFORM                                              20080000
         B     DOEND                   CONFORM FOUND AN EMPTY RESULT OR 20160000
*                                  FILLED RESULT WITH IDENTITY ELEMENT  20240000
         MVC   REPIORF,BREPLF1     ASSUME FLOATING                      20320000
         CLI   COMTYP+3,3          GOOD GUESS?                          20400000
         BE    DOREP11             YES                                  20480000
         MVC   REPIORF,BREPLI1     NO, MAKE IT FIXED                    20560000
DOREP11  BAL   LKR,SETSTORE        SET UP RESULT STORE                  20640000
         BAL   LKR,ALTER          ALTER CONSTANTS TO PROPER INDEX TYPE  20720000
*                                                                       20800000
*                                                                       20880000
*              OUTER LOOP (REPRESENT)                                   20960000
         ON    XOF,BLOW                                                 21040000
         ON    XDZ,REPIZD                                               21120000
         L     1,APT1                                                   21200000
         S     1,TAR               OUTER LOOP ON AX                     21280000
         ST    1,PTOSCODE          AN UNUSED LOCATION                   21360000
         L     4,LB                LENGTH OF B                          21440000
         L     5,ZPT                                                    21520000
REPL1    L     BX,BRT                                                   21600000
REPL5    C     BX,LASTB                                                 21680000
         BE    REPL7                                                    21760000
         SR    BX,4                                                     21840000
         BAL   ZXR,REPF            OUTER LOOP                           21920000
         B     REPLOOP             INNER LOOP                           22000000
REPL6    LR    9,5                                                      22080000
         EX    0,SRESULT                                                22160000
         QUEND                                                          22240000
         L     AX,APT1             RESET A TO SAME  ROW                 22320000
         L     5,ZPT                                                    22400000
         S     5,LZ                                                     22480000
         ST    5,ZPT                                                    22560000
         B     REPL5                                                    22640000
REPL7    S     AX,LA                                                    22720000
         ST    AX,APT1                                                  22800000
         C     AX,PTOSCODE                                              22880000
         BH    REPL1                                                    22960000
         B     DOEND               ALL DONE, CLEAN UP AND QUIT          23040000
DOREPC1  DC    AL1(0,4,8,0,0,4,8)                                       23120000
DOREPC2  DC    AL1(0,0,0,4,8,4,8)                                       23200000
*                                                                       23280000
*                                                                       23360000
*              INTEGER HORNER'S METHOD                                  23440000
BALOOPI  A     AX,TAR              INCREMENT LEFT ARG. THIS CAUSES      23520000
*                                  FIRST ELE OF LEFT ARG SKIPPED.       23600000
         EX    0,AGET              GET NEXT ELE OF LEFT INTO REG1       23680000
         MR    0,2                 MULTIPLY BY IT                       23760000
         SLDA  0,32           MAKE SURE RESULTS FITS IN A               23840000
         LR    1,0            FULLWORD                                  23920000
         BL    BLOW                IT DOESNT. TRY FLOATING POINT        24000000
         EX    0,BGET              GET NEXT ELE OF RT INTO R2           24080000
         AR    2,1                 NEXT PARTIAL RESULT IN R2            24160000
         BCT   5,LOOP5             CONTINUE LOOP IF NECESSARY           24240000
         LR    1,2                 RESULT STORED OUT OF R1              24320000
         B     LOOP6                                                    24400000
*                                                                       24480000
*                                                                       24560000
*              FLOATING HORNERS METHOD                                  24640000
BALOOPF  A     AX,TAR              INCREMENT LEFT ARG                   24720000
         EX    0,AGET              GET NEXT ELE OF LEFT INTO E0         24800000
         MDR   0,2                 MULTIPLY BY IT                       24880000
         EX    0,BGET                                                   24960000
         ADR   2,0                 NEXT PARTIAL RESULT IN E2            25040000
         BCT   5,LOOP5             CONTINUE LOOP IF NECESSARY           25120000
         LDR   0,2                 RESULT STORED OUT OF E0              25200000
         B     LOOP6                                                    25280000
         EJECT                                                          25360000
*              INITIAL CALC REPRESENT                                   25440000
REPF     EX    0,BGET                                                   25520000
         EX    0,REPIORF                                                25600000
*                                                                       25680000
*                                                                       25760000
*              INTEGER REPRESENT                                        25840000
REPLI1   ST    2,TPROD             SAVE CURRENT P (OR B)                25920000
         EX    0,AGET            GET AN ELEMENT OF A                    26000000
         SRDA  2,32                PUT IN ODD REG,SIGN EXTENDED         26080000
         DR    2,1                 P/A,REMAINDER IN 2                   26160000
         LTR   2,2                     IS REMAINDER <0 ?                26240000
         BNL   REP1                NO, GOODIE                           26320000
         LPR   0,1                 THIS IS ABSOLUTELY THE VALUE         26400000
*                                  OF A                                 26480000
         AR    2,0                 MAKE REMAINDER RESIDUE               26560000
REP1     LR    9,2                 RESULT IN R9                         26640000
         L     2,TPROD             RESTORE P                            26720000
         SR    2,9                 SUBTRACT THE RESIDUE                 26800000
         SRDA  2,32                MOVE INTO R3, SIGN EXTENDED          26880000
         DR    2,1                 NEW P IN R2                          26960000
         LR    2,3                                                      27040000
         LR    1,9                 RESULT IN R1 AND R9 ON EXIT          27120000
         BR    ZXR                 RETURN                               27200000
*                                                                       27280000
*                                                                       27360000
*              FLOATING REPRESENT                                       27440000
REPLF1   EX    0,AGET              GET ELEMENT OF A                     27520000
         LTDR  0,0                 A = 0 ?                              27600000
         BNZ   REPLF3                                                   27680000
         LDR   0,2                 YES, RESULT IS REMAINING B           27760000
         SDR   2,2                 NEW B = 0                            27840000
         BR    ZXR                 RETURN                               27920000
REPLF3   STD   0,TPROD             SAVE A FOR NOW                       28000000
         STD   2,TPROD1            SAVE B FOR NOW                       28080000
         L     9,=V(EXRES)                                              28160000
         BALR  LKR,9               USE FLOATING RESIDUE                 28240000
         LDR   6,0                 SAVE RESULT                          28320000
         LD    2,TPROD1            RESTORE B                            28400000
         SDR   2,6                 SUBTRACT RESIDUE                     28480000
         DD    2,TPROD             GET NEW B                            28560000
         LDR   0,6                                                      28640000
*              F2 = NEW B,F0,F6 = ANS                                   28720000
         BR    ZXR                 RETURN                               28800000
*                                                                       28880000
*                                                                       28960000
*              HERE ON FIXED ZERO DIVIDE                                29040000
REPIZD   LTR   2,2                 IS B<0                               29120000
         BL    RANGERR             YES, 0 RESIDUE UNDEFINED             29200000
         LR    1,3                 REST OF B IS LAST RESIDUE            29280000
         SR    2,2                 NEW VALUE OF B                       29360000
         BR    ZXR                 RETURN                               29440000
*                                                                       29520000
*                                                                       29600000
*              INNER LOOP FOR REPRESENT  (CALC2)                        29680000
REPLOOP  LA    ZXR,REPLOOP3         RETURN ADDRESS FOR REPIORF          29760000
REPLOOP1 S     AX,TAR              MOVE TO NEXT ELE OF A                29840000
         C     AX,LASTA            ALL DONE?                            29920000
         BL    REPL6               YES,RETURN                           30000000
         QUEND                                                          30080000
         LR    9,5                                                      30160000
         EX    0,SRESULT               RESULT IS IN R1 OR F0            30240000
         EX    0,REPIORF                                                30320000
REPLOOP3 S     5,TRZ                                                    30400000
         B     REPLOOP1            ITERATE                              30480000
*                                                                       30560000
*                                                                       30640000
BALBASE  BAL   ZXR,BASE                                                 30720000
*              INNER LOOP FOR BASE (CALC2)                              30800000
BBALOOPI B     BALOOPI             BRANCH FOR INTEGER BASE              30880000
BBALOOPF B     BALOOPF             BRANCH FOR FLOATING BASE             30960000
BREPLOOP B     REPLOOP             INNER LOOP REPRESENT (CALC2)         31040000
BREPLI1  B     REPLI1              FIXED  (REPIORF)                     31120000
BREPLF1  B     REPLF1              FLOATING (REPIORF)                   31200000
         EJECT                                                          31280000
         USING *,9                                                      31360000
REDUCE   ST    12,CALLBASE         SAVE THE CALLING BASE REG            31440000
         L     12,=A(MATRIX+6)                                          31520000
         DROP  9                                                        31600000
         ST    LKR,RREG                                                 31680000
         LA    14,(LEND-OPSECT+7)/8*8+16(,13)                      P052 31760000
         MVC   RTYPE,RSTYPE        FOR COMPATIBILITY WITH MATRIX PROD   31840000
         MVC   POSTBLOW,=A(MBLOWRTN)                                    31920000
         L     BX,RHBASE           M-REL POINTER TO RIGHT ARG           32000000
         SR    1,1                                                      32080000
         ST    1,RPTEST            NOT REPRESENT                        32160000
         IC    1,OPERATOR+3                                             32240000
         A     1,=A(OPTAG)                                              32320000
         TM    1(1),1              IS IT A SCALAR OP                    32400000
         BZ    SYNTERR             NO                                   32480000
         LA    4,1                 ASSUME WE HAVE A BARRED SLASH        32560000
*                                  DEFAULT INDEX TO 1                   32640000
         CLI   OPERATOR+2,1+2*ZCOLSLSH                                  32720000
         BE    R10                 YES WE GUESSED RIGHT                 32800000
         CLI   OPERATOR+2,1+2*ZSLASH                                    32880000
         BE    R5                  ITS A NORMAL SLASH                   32960000
         B     SYNTERR             MUST BE SCAN OR OTHER, SYNT ER   G01 33040000
*                                                                       33120000
R5       LH    4,MRANK(BX)         DEFAULT INDEX IS                     33200000
         SRL   4,2                 RHORHO B                             33280000
R10      TM    INDBASE,X'C0'                                            33360000
         BZ    R19                                                      33440000
         BO    INDEXER                                                  33520000
         L     4,INDEX                                                  33600000
         LA    4,1(4)              WHY DO I WANT 1 ORIGIN               33680000
R19      ST    4,INDEX1            STORE IN NEW PLACE INCASE BLOWUP     33760000
R20      BAL   LKR,DORED                                                33840000
         B     DOEND                INDEX WAS OUT OF RANGE              33920000
         L     3,SD                DO I FILL WITH IDENTITY?             34000000
         LTR   3,3                                                      34080000
         BNE   DOR40                                                    34160000
         L     1,TPROD                                                  34240000
         LD    0,TPROD2                                                 34320000
         L     2,RXRHO                                                  34400000
         BAL   LKR,FILL            FILL UP THE ARRAY                    34480000
DOR40    MVC   CALC1,BRCCI                                              34560000
         MVC   CALC2,BREDUCEF      ASSUME FLOATING INNER LOOP           34640000
         CLI   COMTYP+3,3          GOOD GUESS?                          34720000
         BE    DOR50               TA DA                                34800000
         MVC   CALC2,BREDUCEI                                           34880000
DOR50    BAL   LKR,SETSTORE                                             34960000
         L     9,LB                                                     35040000
         IC    9,SLIST-1(9)                                             35120000
         LM    1,3,TBR                                                  35200000
         SLL   1,0(9)              TBR                                  35280000
         SLL   3,0(9)              SBR                                  35360000
         ST    3,SBR                                                    35440000
         ST    1,TBR1                                                   35520000
         S     3,LB                SBR - 1                              35600000
         ST    3,SBRM1                                                  35680000
         LA    5,1                 FOR COMPARISONS IN ALTER             35760000
         BAL   LKR,ALTER6          SHARE SETUP OF Z AND B               35840000
         L     1,RTYPE             DEFINE CONVERSION CODE               35920000
         SLA   1,2                 TO CONVERT RESULT OF OPERATION       36000000
         A     1,COMTYP            BACK TO THE ARGUMENT                 36080000
         IC    1,FTCHTYP-5(1)      TYPE                                 36160000
         ST    1,RTOSCODE          ONLY USED IF NEEDED                  36240000
         ON    XOF,BLOW                                                 36320000
         L     BX,BRT                                                   36400000
         L     AX,TBL                                                   36480000
RLOOP1   S     BX,SBR              MOVE TO NEXT HYPERPLANE              36560000
         L     4,TBR                                                    36640000
RLOOP3   A     BX,SBRM1            MOVE TO NEXT STARTING POINT          36720000
         ST    4,R4SAVE            SCALAR OP ROUTINE MAY USE REG 4      36800000
         EX    0,CALC1                                                  36880000
         L     5,SD                NUMBER OF ELEMENTS FORMING ONE RESUL 36960000
         BCT   5,RLOOP5            GET OUT EARLY ON                     37040000
         QUEND                                                     2549 37120000
         B     RLOOP6              REDUCTION OF ONE ELEMENT             37200000
RLOOP5   S     BX,TBR1                                                  37280000
         QUEND                                                          37360000
         EX    0,CALC2                                                  37440000
*        BCT   5,RLOOP5            THIS IS DONE IN REDUCE               37520000
RLOOP6   L     9,ZPT                                                    37600000
         EX    0,SRESULT                                                37680000
         S     9,LZ                                                     37760000
         ST    9,ZPT                                                    37840000
         L     4,R4SAVE                                                 37920000
         BCT   4,RLOOP3                                                 38000000
         BCT   AX,RLOOP1                                                38080000
         B     DOEND                                                    38160000
*                                                                       38240000
*                                                                       38320000
*              FIXED INNER LOOP REDUCE                                  38400000
REDUCEI  ST    1,TPROD             RESULT SO FAR                        38480000
         EX    0,CALC1             GET NEXT ELEMENT                     38560000
         L     2,TPROD             PREVIOUS RESULT                      38640000
         B     RD11                                                     38720000
*                                                                       38800000
*                                                                       38880000
*              FLOATING INNER LOOP REDUCE                               38960000
REDUCEF  STD   0,TPROD             RESULT SO FAR                        39040000
         EX    0,CALC1             GET NEXT ELEMENT                     39120000
         LD    2,TPROD                                                  39200000
RD11     L     9,OPRN                                                   39280000
         BALR  LKR,9               EXECUTE OPERATOR                     39360000
         BCT   5,RD15              IS THIS THE LAST PARTIAL RESULT      39440000
         B     RLOOP6              YES                                  39520000
RD15     CLC   RTYPE+3(1),COMTYP+3 MUST RESULT BE CONVERTED BACK TO     39600000
*                                  ARG TYPE OF OPERATOR                 39680000
         BE    RLOOP5              NO                                   39760000
         CLI   COMTYP+3,4          CHECK FOR EQ OR NEQ RED OF CHAR 3047 39840000
         BE    RLOOP5              BRANCH IF EQ OR NEQ OF CHAR     3047 39920000
         ST    1,PRESULT          ONLY A LOGICAL OPERATOR NEEDS THIS    40000000
         MVC   CCODE,RTOSCODE      YES,SET CONVERSION CODE              40080000
         MVC   LINKS,=A(RLOOP5)    SET GETD RETURN ADDRESS              40160000
         B     GETD                                                     40240000
*                                                                       40320000
*                                                                       40400000
*              REDUCE INITIAL CALC                                      40480000
BASE     DS    0H                  BASE VALUE INITIAL CALC              40560000
RCCI     EX    0,BGET             GET AN ELEMENT OF B                   40640000
         LR    1,2                                                      40720000
         LDR   0,2                 IN R1 OR F0                          40800000
         BR    ZXR                                                      40880000
*                                                                       40960000
*                                                                       41040000
BRCCI    BAL   ZXR,RCCI                                                 41120000
BREDUCEI B     REDUCEI                                                  41200000
BREDUCEF B     REDUCEF                                                  41280000
         EJECT                                                          41360000
*              MAKE ALL CONSTANTS ELEMENT,FULLWORD ,OR DOUBLEWORD       41440000
*                                  ENTRY FOR IN-BASE                    41520000
ALTER    L     9,LB                B CONSTANTS                          41600000
         IC    9,SLIST-1(9)        AMOUNT OF SHIFT FOR B                41680000
         LM    2,3,TBR1                                                 41760000
         SLL   2,0(9)              TBR1                                 41840000
         SLL   3,0(9)              SBR                                  41920000
         STM   2,3,TBR1                                                 42000000
         S     3,LB                SBR-1                                42080000
         ST    3,SBRM1                                                  42160000
*                                                                       42240000
*                                  ENTRY FOR OUT-REP                    42320000
ALTER1   L     9,LA                                                     42400000
         IC    9,SLIST-1(9)                                             42480000
         LM    1,2,AINC                                                 42560000
         SLL   1,0(9)              AINC                                 42640000
         SLL   2,0(9)              TAR                                  42720000
         STM   1,2,AINC                                                 42800000
         LA    5,1                 FOR COMPARISONS                      42880000
         C     5,LA                IS A AN ELEMENT INDEX                42960000
         BNE   ALTER5              NO                                   43040000
         SR    AX,AX               YES,DEFINE IT SO                     43120000
ALTER5   ST    AX,LASTA                                                 43200000
         L     1,LHXRHO            ELEMENTS IN A                        43280000
         BCTR  1,0                 MAKE IT ZERO ORIGIN                  43360000
         SLL   1,0(9)                                                   43440000
         AR    AX,1                START A AT RIGHTMOST ELEMENT         43520000
         ST    AX,APT1                                                  43600000
         L     1,TRZ                                                    43680000
         M     0,LZ                                                     43760000
         ST    1,TRZ                                                    43840000
ALTER6   C     5,LZ                IS Z AN ELEMENT INDEX ?              43920000
         BNE   ALTER7              NO                                   44000000
         SR    ZXR,ZXR             YES, DEFINE IT SO                    44080000
ALTER7   ST    ZXR,LASTZ                                                44160000
         L     1,RXRHO             ELEMENTS IN RESULT                   44240000
         BCTR  1,0                 MAKE IT ZERO ORIGIN                  44320000
         M     0,LZ                                                     44400000
         AR    ZXR,1                                                    44480000
         ST    ZXR,ZPT                                                  44560000
         ST    ZXR,ZPT1                                                 44640000
*                                  FROM HERE ZPT NOT ZXR IS             44720000
*                                  THE RESULT INDEX                     44800000
         C     5,LB                IS B AN ELEMENT INDEX                44880000
         BNE   ALTER9              NO                                   44960000
         SR    BX,BX               YES, DEFINE IT SO                    45040000
ALTER9   ST    BX,LASTB                                                 45120000
         L     1,RHXRHO                                                 45200000
         M     0,LB                                                     45280000
         AR    BX,1                                                     45360000
         ST    BX,BRT              B STARTS 1 BEYOND RIGHT ELEMENT      45440000
         BR    LKR                                                      45520000
SLIST    DC    AL1(0,0,0,2,0,0,0,3)    AMOUNT OF SHIFT FOR GIVEN LENGTH 45600000
*                                                                       45680000
*                                                                       45760000
BLOW     L     9,SVI               ALL WAS FOR NOTHING (SIGH)           45840000
         LA    9,4(9)                                                   45920000
         ST    9,SVI                                                    46000000
         L     1,M(9)                                                   46080000
         MKG   1                   GET RID OF FIXED RESULT              46240000
         LA    0,3                 FORCE FLOATING TYPE                  46320000
         L     9,POSTBLOW          ADDRESS OF RESTART ROUTINE           46400000
         L     12,CALLBASE         OPCTL BASE REG                       46480000
         BR    9                                                        46560000
         DC    H'0'                REMOVE THIS CARD TO SAVE 2 BYTES     46640000
         EJECT                                                          46720000
*              FETCH ROUTINES                                           46800000
AFETCH   STM   2,4,FTSAVE           DON'T DISTROY B ARG IF ANY          46880000
         LM    3,4,LCFTYPE          TYPE AND DATA ORIGIN                46960000
         LR    2,AX                 ELEMENT INDEX                       47040000
         LR    9,LKR                SAVE RETURN                         47120000
         ICALL FETCH                RESULT IN R0 OR F0                  47200000
         LR    1,0                  FIXED RESULT IN R1                  47280000
         LM    2,4,FTSAVE                                               47360000
         BR    9                    RETURN                              47440000
*                                                                       47520000
*                                                                       47600000
BFETCH   STM   1,4,FTSAVE           DON'T DISTROY A ARG IF ANY          47680000
         STD   0,DTEMP              SAVE FLOATING A ARG                 47760000
         LM    3,4,RCFTYPE          TYPE AND DATA ORIGIN                47840000
         LR    2,BX                 ELEMENT INDEX                       47920000
         LR    9,LKR                                                    48000000
         ICALL FETCH                RESULT IN R0 OR F0                  48080000
         LDR   2,0                  PUT FLOATING RESULT IN F2           48160000
         LD    0,DTEMP              RESTORE FLOATING A ARG              48240000
         LR    2,0                  FIXED RESULT IN R2                  48320000
         L     1,FTSAVE                                                 48400000
         LM    3,4,FTSAVE+8                                             48480000
         BR    9                                                        48560000
*                                                                       48640000
*                                                                       48720000
GETD     STM   2,4,FTSAVE                                               48800000
         L     3,CCODE              THE CONVERSION CODE                 48880000
         LA    4,PRESULT            ADDRESS OF INTERMEDIATE RESULT      48960000
         SR    4,MR                 RELATIVEIZE IT                      49040000
         SR    2,2                  ELEMENT INDEX                       49120000
         ICALL FETCH                RESULT IN R0 OR F0                  49200000
         LR    1,0                  FIXED RESULT IN R1                  49280000
         L     LKR,LINKS            RETURN ADDRESS                      49360000
         LM    2,4,FTSAVE                                               49440000
         BR    LKR                                                      49520000
*                                                                       49600000
*                                                                       49680000
AFTOF    SR    9,9                  AN A ARG                            49760000
         LR    2,AX                 ELEMENT INDEX                       49840000
         B     FTOF                                                     49920000
*                                                                       50000000
*                                                                       50080000
BFTOF    LA    9,4                  A B ARG                             50160000
         LR    2,BX                 ELEMENT INDEX                       50240000
         B     FTOF                                                     50320000
*                                                                       50400000
*                                                                       50480000
*              INLINE CONVERSION ROUTINES                               50560000
*                                                                       50640000
*              OFF BOUNDARY FLOATING TO FLOATING CONVERT                50720000
*              R2 HAS 0-ORIGIN ELEMENT INDEX                            50800000
FTOF     SLA   2,3                 MAKE IT A DOUBLEWORD INDEX           50880000
         EX    0,ADBASE(9)                                              50960000
         AR    2,MR                ABSOLUTE ADDRESS OF DATA             51040000
         LM    2,3,0(2)                                                 51120000
         STM   2,3,DTEMP1          PUT IT ON BOUNDARY                   51200000
         EX    0,LOADF(9)          PUT IN PROPER REGISTER               51280000
         BR    LKR                 RETURN                               51360000
*                                                                       51440000
LOADF    LD    0,DTEMP1                                                 51520000
         LD    2,DTEMP1                                                 51600000
         LD    0,DTEMP1                                                 51680000
*                                                                       51760000
ADBASE   A     2,LHORG                                                  51840000
         A     2,RHORG                                                  51920000
         BCR   0,0                                                      52000000
         EJECT                                                          52080000
*              THE CENTRAL COMMON LOOP                                  52160000
*                                  THIS IS 'THE' LOOP                   52240000
OLOOP    S     BX,SBR                                                   52320000
         ST    BX,BRT                                                   52400000
LOOP     L     4,TBR               THE NUMBER OF COLUMNS                52480000
LOOP3    A     BX,SBRM1                                                 52560000
         ST    4,R4SAVE                                                 52640000
         L     5,SD                                                     52720000
         EX    0,CALC1             PERFORM THE INITIAL CALCULATION      52800000
         BCT   5,LOOP5             MORE THAN ONE ELEMENT PER RESULT     52880000
         QUEND                                                     2549 52960000
         B     LOOP7               NO                                   53040000
LOOP5    S     BX,TBR1             MOVE TO NEXT COL OF B                53120000
         QUEND                     TO WHOM IT MAY CONCERN               53200000
         EX    0,CALC2             FORM NEXT PARTIAL RESULT             53280000
*                                  INNER PRODUCT DOES ITS OWN BCT       53360000
LOOP5A   BCT   5,LOOP5             GO BACK IF STILL MORE ELEMENTS       53440000
LOOP6    S     BX,TBR1                                                  53520000
LOOP7    L     9,ZPT                                                    53600000
*              RECALL ZXR USED FOR LINKAGE NOT Z INDEX                  53680000
*              EXCELLENT JOB SECURITY                                   53760000
         EX    0,SRESULT           STORE THE ANSWER                     53840000
         S     9,LZ                POSITION FOR NEXT RESULT             53920000
         ST    9,ZPT                                                    54000000
         L     AX,APT1             SET A TO SAME ROW                    54080000
         L     4,R4SAVE                                                 54160000
         BCT   4,LOOP3             TAKE ROW OF A AGAINST NEXT COL OF B  54240000
         S     AX,AINC             MOVE TO NEXT ROW OF A                54320000
         ST    AX,APT1                                                  54400000
         L     BX,BRT              START OVER ON B WITH NEW ROW OF A    54480000
         C     9,LASTZ             ALL DONE ?                           54560000
         BNL   LOOP                CONTINUE IF NOT                      54640000
         B     DOEND                                                    54720000
         EJECT                                                          54800000
*              FILL AN M ENTRY WITH A CONSTANT                          54880000
*              R1 OR F0 = CONSTANT ( DEPENDS ON RTYPE)                  54960000
*              R2 = # OF ELEMENTS  ( 0 IS OK)                           55040000
*              ZXR = M-REL ADDRESS OF DATA                              55120000
FILL     LTR   4,2                                                      55200000
         BNP   DOEND               NOTHING TO MOVE                      55280000
         BAL   LKR,SETSTORE                                             55360000
         L     3,LZ                LENGTH OF ONE ITEM                   55440000
         C     3,=F'1'             CAN I STORE  RESULT DIRECTLY         55520000
         BNE   FILL3               YES                                  55600000
         SR    ZXR,ZXR             NO GET ELEMENT INDEX                 55680000
FILL3    LR    9,ZXR                                                    55760000
         EX    0,SRESULT                                                55840000
         AR    ZXR,3                                                    55920000
         QUEND                                                          56000000
         BCT   4,FILL3                                                  56080000
         B     DOEND                                                    56160000
*                                                                       56240000
*                                                                       56320000
FSTOREF  LR    10,9                                                     56400000
         SLL   10,3                                                     56480000
         STD   0,TPROD2            STORE ON BOUNDARY                    56560000
         AR    10,MR                                                    56640000
         A     10,RESORG                                                56720000
         MVC   0(8,10),TPROD2      MOVE TO OFF BOUNDARY                 56800000
         BR    LKR                                                      56880000
CSTORE   LR    10,9                                                3037 56960000
         A     10,RESORG           R10 IS OFFSET TO RESULT         3037 57040000
         SRL   1,24                STORE SINGLE-CHARACTER ARG      3037 57120000
         STC   1,0(10,MR)           AS RESULT.                     3037 57200000
         BR    LKR                                                 3037 57280000
*                                                                       57360000
*                                                                       57440000
*              THE FOLLOWING CODE IS TAKEN FROM THE ORIGINAL            57520000
*              ONLY THE NAMES HAVE BEEN CHANGED TO PROTECT THE CODER    57600000
BSTORE   STM   2,3,RSAVE1                                               57680000
         LR    2,9                     ELEMENT INDEX                    57760000
         SRDL  2,3                 R2 = BYTE INDEX (DATA REL)           57840000
         A     2,RESORG            BYTE INDEX (M-REL)                   57920000
         LA    2,M(2)              BYTE INDEX (ABSOLUTE)                58000000
         SRL   3,29                BIT INDEX                            58080000
         LTR   1,1                                                      58160000
         BNL   BSTORE0                                                  58240000
         IC    3,ONES(3)           STORE A ONE                          58320000
         EX    3,OI                                                     58400000
         LM    2,3,RSAVE1                                               58480000
         BR    LKR                 RETURN                               58560000
BSTORE0  IC    3,ZEROS(3)          STORE A ZERO                         58640000
         EX    3,NI                DO IT                                58720000
         LM    2,3,RSAVE1                                               58800000
         BR    LKR                 RETURN                               58880000
ONES     DC    X'8040201008040201'                                      58960000
ZEROS    DC    X'7FBFDFEFF7FBFDFE'                                      59040000
NI       NI    0(2),0                                                   59120000
OI       OI    0(2),0                                                   59200000
         SPACE 6                                                        59280000
BRZXR    BR    ZXR                                                      59360000
NOP      BCR   0,0                                                      59440000
         EJECT                                                          59520000
*              ASSUMES AX,BX HAVE M-REL POINTERS                        59600000
*              ASSUMES RTYPE OF OPERATOR IS KNOWN                       59680000
*              ALL RESULTS ARE ELEMENT INDEXES                          59760000
CONFORM  ST    LKR,LINKS                                                59840000
         L     AX,LHBASE                                                59920000
         L     BX,RHBASE                                                60000000
         MVC   POSTBLOW,=A(BLOWRTN) BLOWUP RECOVERY                     60080000
         SR    ZXR,ZXR                                                  60160000
         LA    9,1                 NEEDED OFTEN                         60240000
         MVC   LCFTYPE,LCTYPE                                           60320000
         MVC   RCFTYPE,RCTYPE                                           60400000
         ST    9,SD                SUPPRESSED DIMENSION                 60480000
         LR    2,9                 ASSUME A SCALAR                      60560000
         LR    3,9                 ASSUME B SCALAR                      60640000
         LH    0,MRANK(AX)         RANK OF A                            60720000
         LH    1,MRANK(BX)         RANK OF B                            60800000
         LTR   0,0                 IS A SCALAR                          60880000
         BZ    C1                  YES                                  60960000
         AR    AX,0                                                     61040000
         L     2,MRHO-4(AX)        GET RHOA(RHORHOA)                    61120000
         SR    AX,0                                                     61200000
C1       LTR   1,1                 IS B SCALAR                          61280000
         BZ    C3                  YES                                  61360000
         L     3,MRHO(BX)          GET RHOB(1)                          61440000
C3       C     ZXR,OUT             IS THIS AN OUTER PRODUCT             61520000
         BE    C7                  YES                                  61600000
         ST    2,AINC              NO,CHECK CONFORMABILITY              61680000
         ST    3,SD                SD=RHOB(1)                           61760000
         CR    2,3                 RHOA(RHORHOA) = RHOB(1) ?            61840000
         BE    C21                     YES,STANDARD CONFORMABILITY      61920000
         CR    2,9                 RHOA(RHORHOA) = 1 ?                  62000000
         BE    C21                 YES,EXTENDED CONFORMABILITY          62080000
         ST    2,SD                SD=RHOA(RHORHOA)                     62160000
         CR    3,9                 RHOB(1) = 1 ?                        62240000
         BE    C21                 YES, EXTENDED CONFORMABILITY         62320000
         B     CONERR              ARGS DO NOT CONFORM                  62400000
*                                  CALC ALL SORTS OF USEFUL NUMBERS     62480000
*              HERE FOR OUTER PRODUCT AND REPRESENT                     62560000
C7       ST    9,AINC                                                   62640000
         L     5,=F'-4'                                                 62720000
         STM   0,1,DTEMP           SAVE RANKS                           62800000
         LA    ZXR,MRHO+4(AX)      GET PROD OF RT DIMENSIONS OF A       62880000
         LR    3,9                 PRIME THE PRODUCT                    62960000
         LR    4,0                                                      63040000
         AR    4,5                                                      63120000
         BXLE  4,5,C9              REDUCE RANK BY ONE                   63200000
         M     2,M-M(4,ZXR)                                             63280000
         BXH   4,5,*-4                                                  63360000
C9       ST    3,TAR                                                    63440000
         M     2,RHXRHO                                                 63520000
         ST    3,TRZ                                                    63600000
         L     1,LHXRHO            DETERMINE NUMBER OF                  63680000
         M     0,RHXRHO            ELEMENTS IN THE RESULT               63760000
         B     C41                                                      63840000
C21      C     ZXR,SD              ZERO DIMENSION ?                     63920000
         BNE   C21A                    NO, OK                           64000000
         SR    5,5                                                      64080000
         IC    5,OPERATOR+2                                             64160000
         BAL   LKR,GETID               GET IDENTITY ELEMENT AND ALTER R 64240000
C21A     C     9,SD                DIMENSION = 1                        64320000
         BNE   C21B                                                     64400000
         MVC   RTYPE+3(1),RSTYPE+3 OK FOR BASE                          64480000
*              RESULT TYPE = ARG TYPE, RESULT IS B                      64560000
*              SUBTRACT ONE FROM RANK OF A & B IF NOT SCALAR            64640000
*              SO RESULT RANK WORKS OUT                                 64720000
C21B     LTR   0,0                 CHECK A                              64800000
         BZ    C22                 NOT SCALAR                           64880000
         S     0,OUT               ISN'T THIS PLANNING AHEAD            64960000
C22      LTR   1,1                 CHECK B                              65040000
         BZ    C25                                                      65120000
         S     1,OUT                                                    65200000
C25      ST    9,TAR                                                    65280000
         ST    3,SBR               SBR USED AS A TEMP ONLY              65360000
         CR    9,2                 1=RHOA(RHORHOA)                      65440000
         BNE   C26                                                      65520000
         ST    ZXR,TAR                                                  65600000
C26      STM   0,1,DTEMP           SAVE RANKS                           65680000
         L     5,=F'-4'                                                 65760000
         LA    ZXR,MRHO+4(BX)      GET PROD OF RT DIM OF B              65840000
         LR    3,9                 PRIME THE PRODUCT                    65920000
         BXLE  1,5,C28             REDUCE RANK BY ONE                   66000000
*              REMEMBER RANKS ALREADY REDUCED BY ONE                    66080000
         M     2,M-M(1,ZXR)                                             66160000
         BXH   1,5,*-4                                                  66240000
C28      ST    3,TBR                                                    66320000
         ST    3,TBR1                                                   66400000
         C     9,SBR               1 = RHOB(1) ?                        66480000
         BNE   C29                 NO                                   66560000
         XC    TBR1(4),TBR1                                             66640000
C29      LR    1,3                 STORAGE FROM B                       66720000
         LA    ZXR,MRHO(AX)        GET PROD OF LEFT DIM OF A            66800000
         LR    3,9                 PRIME THE PRODUCT                    66880000
         LR    4,0                                                      66960000
         BXLE  4,5,C30             REDUCE RANK BY ONE                   67040000
         M     2,M-M(4,ZXR)                                             67120000
         BXH   4,5,*-4                                                  67200000
C30      MR    0,3                 NUM OF ELEMENTS IN RESULT            67280000
         L     5,SBR                                                    67360000
         M     4,TBR1                                                   67440000
         ST    5,SBR                                                    67520000
C41      ST    1,RXRHO                                                  67600000
         LTR   0,0            IN CASE OVERFLOW IN NUMBER                67680000
         BNZ   WSFULL         OF ELEMENTS                               67760000
         L     ZXR,DTEMP                                                67840000
         A     ZXR,DTEMP+4         =4 * RANK OF RESULT                  67920000
         C     ZXR,=F'256'                                              68000000
         BH    RANKERR                                                  68080000
         L     1,RXRHO                                                  68160000
         LR    2,ZXR                                                    68240000
         L     3,RTYPE                                                  68320000
         LR    5,3                 SAVE TYPE FOR LATER                  68400000
         L     10,=A(OPSPACE)                                           68480000
         BALR  LKR,10                                                   68560000
         STH   ZXR,MRANK(1)        STUFF RANK                           68640000
         STC   5,MTYPE(1)          AND TYPE                             68720000
         ST    1,RBASE                                                  68800000
         LA    ZXR,MRHO(1)         AT RHOZ (ABSOLUTE)                   68880000
*                                  IN CASE OF A GARBAGE COLLECTION      68960000
         L     AX,LHBASE                                                69040000
         L     BX,RHBASE                                                69120000
*                                  MOVE IN RESULT DIMENSION             69200000
         LA    5,MRANK(AX)         AT RANK A (ABSOLUTE)                 69280000
         LH    4,M-M(5)            GET RANK OF A                        69360000
         S     4,OUT               =# OF BYTES TO MOVE                  69440000
         BAL   LKR,MOVED                                                69520000
         LR    AX,5                AX POINTS TO DATA (ABSOLUTE)         69600000
         LA    5,MRANK(BX)         AT RANK B (ABSOLUTE)                 69680000
         SR    4,4                 ASSUME INNER PRODUCT                 69760000
         CLI   OUT+3,0             IS IT OUTER                          69840000
         BNE   C47                 NO                                   69920000
         LH    4,M-M(5)            GET RANK B                           70000000
C47      BAL   LKR,MOVED                                                70080000
         LR    BX,5                BX POINTS TO DATA (ABSOLUTE)         70160000
*              MAKE ALL POINTERS TO DATA M-REL                          70240000
         SR    AX,MR                                                    70320000
         SR    BX,MR                                                    70400000
         SR    ZXR,MR                                                   70480000
         ST    AX,LHORG                                                 70560000
         ST    BX,RHORG                                                 70640000
         ST    ZXR,RESORG                                               70720000
         SR    0,0                                                      70800000
         L     2,RXRHO                                                  70880000
         LTR   2,2                 IF NO ELE IN RESULT WERE ALL DONE    70960000
         BNP   C53                 FILL WILL GET OUT EARLY              71040000
         C     0,SD                    IF SD=0,THIS IS INNER PROD,FILL  71120000
         BNE   C55                 WITH IDENTITY ELEMENT                71200000
         L     1,TPROD             FIXED IDENTITY ELEMENT               71280000
         LD    0,TPROD2            FLOATING IDENTITY ELEMENT            71360000
C53      L     LKR,LINKS                                                71440000
         BR    LKR                 RETURN - ALL DONE                    71520000
C55      BAL   LKR,GETLINK                                              71600000
         L     LKR,LINKS                                                71680000
         B     4(LKR)              NORMAL RETURN                        71760000
*                                                                       71840000
*                                                                       71920000
*              GET IDENTITY ELEMENT OF NOP1                             72000000
*              DISTROYS F0                                              72080000
*              PUTS ELEMENTS IN TPROD(FIXED),TPROD2(FLOAT)              72160000
*              USES RSAVE AS A SAVE AREA                                72240000
*              ALTERS RTYPE TO BE TYPE OF IDENTITY ELEMENT              72320000
GETID    CLI   RPTEST+3,0          IS THIS INNER OR BASE.               72400000
         BE    GETID3              ITS INNER,GET IDENTITY OF THE OPERA  72480000
         ST    ZXR,TPROD           ITS BASE, IDENTITY = 0               72560000
         ST    9,RTYPE             TYPE IS BOOLEAN                      72640000
         BR    LKR                                                      72720000
GETID3   ST    0,RSAVE1                                                 72800000
         LR    9,5                                                      72880000
         SLA   9,2                 INSTRUCTION FOR                      72960000
         A     9,=A(IDENTS-4)      IDENTITY ELEMENT                     73040000
         L     0,4(9)              GET TYPE OF IDENTITY                 73120000
         LTR   0,0                 IF ZERO,NO IDENTITY                  73200000
         BZ    RANGERR1                                                 73280000
         ST    0,RTYPE                                                  73360000
         EX    0,0(9)              LOAD THE ELEMENT                     73440000
         ST    0,TPROD             FIXED                                73520000
         STD   0,TPROD2            FLOATING                             73600000
         L     0,RSAVE1                                                 73680000
         LA    9,1                                                      73760000
         BR    LKR                                                      73840000
*                                                                       73920000
*                                                                       74000000
*              AX,BX =M-REL ADDRESSES OF DATA (NOT BASE ADDRESS)        74080000
GETLINK  SR    4,4                                                      74160000
         LM    2,3,LCTYPE          GET CONVERT TYPE OF ARGS             74240000
         C     2,=F'3'             IS IT FLOATING TO FLOATING ?         74320000
         BNE   GETL3               NO                                   74400000
         LA    9,M(AX)             ABSOLUTE POINTER TO DATA             74480000
         N     9,=F'7'             IS IT ON BOUNDARY                    74560000
         BNZ   GETL3               NO, WEEFETCH IT                      74640000
         LA    2,14           A SPECIAL LOAD TYPE FOR ON BOUND          74720000
GETL3    IC    4,LLIST-1(2)        GET LENGTH OF A                      74800000
         ST    4,LA                                                     74880000
         SLL   2,2                 GET INDEX TO BRANCH LIST             74960000
         L     9,ALIST-4(2)                                             75040000
         ST    9,AGET                                                   75120000
GETL5    C     3,=F'3'             FLOATING TO FLOATING                 75200000
         BNE   GETL13              NO                                   75280000
         LA    9,M(BX)             ABSOLUTE POINTER   TO DATA           75360000
         N     9,=F'7'             IS IT ON BOUNDARY                    75440000
         BNZ   GETL13              NO,WE FETCH IT                       75520000
         LA    3,14           A SPECIAL LOAD TYPE FOR ON BOUND          75600000
GETL13   IC    4,LLIST-1(3)         GET LENGTH OF B                     75680000
         ST    4,LB                                                     75760000
         SLL   3,2                 GET INDEX TO BRANCH LIST             75840000
         L     9,BLIST-4(3)                                             75920000
         ST    9,BGET                                                   76000000
         BR    LKR                                                      76080000
*                                                                       76160000
*                                                                       76240000
*                                                                       76320000
*              BRANCH LIST FOR A (LEFT) ARG                             76400000
         DC    0F'0'                                                    76480000
ALIST    BAL   LKR,AFETCH          B-B                                  76560000
         L     1,M(AX)             I-I                                  76640000
         BAL   LKR,AFTOF           F-F OFF BOUNDARY                     76720000
         BAL   LKR,AFETCH          C-C                                  76800000
         BAL   LKR,AFETCH          B-I                                  76880000
         BAL   LKR,AFETCH          B-F                                  76960000
         BAL   LKR,AFETCH          I-B                                  77040000
         BAL   LKR,AFETCH          I-F                                  77120000
         BAL   LKR,AFETCH          F-B                                  77200000
         BAL   LKR,AFETCH          F-I                                  77280000
         BAL   LKR,AFETCH     F-B UNFUZZED                              77360000
         BAL   LKR,AFETCH     F-I UNFUZZED                              77440000
         LA    1,255               N-C                                  77520000
         LD    0,M(AX)             F-F ON BOUNDARY                      77600000
*                                                                       77680000
*                                                                       77760000
*                                                                       77840000
*              BRANCH LIST FOR B (RIGHT) ARG                            77920000
BLIST    BAL   LKR,BFETCH          B-B                                  78000000
         L     2,M(BX)             I-I                                  78080000
         BAL   LKR,BFTOF           F-F ON BOUNDARY                      78160000
         BAL   LKR,BFETCH          C-C                                  78240000
         BAL   LKR,BFETCH          B-I                                  78320000
         BAL   LKR,BFETCH          B-F                                  78400000
         BAL   LKR,BFETCH          I-B                                  78480000
         BAL   LKR,BFETCH          I-F                                  78560000
         BAL   LKR,BFETCH          F-B                                  78640000
         BAL   LKR,BFETCH          F-I                                  78720000
         BAL   LKR,BFETCH     F-B UNFUZZED                              78800000
         BAL   LKR,BFETCH     F-I UNFUZZED                              78880000
         LA    2,255               N-C                                  78960000
         LD    2,M(BX)             F-F OFF BOUNDARY                     79040000
*                                                                       79120000
*                                                                       79200000
*                                                                       79280000
LLIST    DC    AL1(1,4,1,1,1,1,1,1,1,1,1,1,1,8) ARGUMENT LENGTHS        79360000
         EJECT                                                          79440000
*              GENERAL MOVE DIMENSION ROUTINE                           79520000
*              R5 = ABSOLUTE PT TO RANK OF SOURCE                       79600000
*              R4 = 4*ZERO ORIGIN SUPPRESSED DIMENSION                  79680000
*              ASSUMES ZX IS ABSOLUTE PT TO RHOZ                        79760000
*              ZX AND R5 POINT TO DATA AT END                           79840000
MOVED    LH    3,0(5)              GET RANK OF SOURCE                   79920000
*              CAN ANYTHING BE  OVED LEFT OF SD                         80000000
MOVED5   LTR   4,4                 SD                                   80080000
         BP    MOVED7              YES                                  80160000
         SR    4,4                 SCALAR GIVES -4                      80240000
         B     MOVED9                                                   80320000
MOVED7   BCTR  4,0                 REG4 IS AMOUNT TO BE MOVED           80400000
         EX    4,MOVE1             GOODY ALL MOVED                      80480000
         LA    4,1(4)                                                   80560000
MOVED9   LA    5,MRHO-MRANK(4,5)   NOW 5 POINTS AT WORD BOUNT           80640000
         LA    ZXR,0(4,ZXR)        Z READY FOR MORE                     80720000
*                                  FIND OUT HOW MUCH IS LEFT            80800000
         LA    4,4(4)              SO WE SKIP SUPPRESSED DIM            80880000
         SR    3,4                                                      80960000
         BNP   MOVED21             NO MORE TO MOVE                      81040000
         BCTR  3,0                 GET THE LENGTH CODE                  81120000
         EX    3,MOVE2                                                  81200000
         LA    ZXR,1(3,ZXR)        DONE AT LAST                         81280000
         LA    5,1(5)                                                   81360000
MOVED21  LA    5,4(3,5)            COUNT SKIPPED DIMENSION              81440000
*                                  LEAVE 5 PT AT DATA (ABSOLUTE)        81520000
         BR    LKR                                                      81600000
MOVE1    MVC   0(0,ZXR),MRHO-MRANK(5)                                   81680000
MOVE2    MVC   0(0,ZXR),4(5)        EXECUTED MVC                        81760000
         EJECT                                                          81840000
DORED    ST    LKR,LINKS                                                81920000
         MVC   RCFTYPE,RCTYPE                                           82000000
         LH    2,MRANK(BX)         4 * RANK OF B                        82080000
         L     5,INDEX1                                                 82160000
         SLL   5,2                 4* INDEX                             82240000
         LA    9,1                 NEEDED OFTEN                         82320000
         LTR   5,5                 IS INDEX TOO LOW                     82400000
         BP    DOR3                NO                                   82480000
         LTR   2,2                 LET A SCALAR SLIP BY                 82560000
         BNZ   INDEXER             NOT A SCALAR                         82640000
         ST    9,TBL               ALL DIMENSION PRODUCTS = 1           82720000
         LR    5,9                                                      82800000
         ST    5,SD                                                     82880000
         LR    1,9                                                      82960000
         B     DOR10               JUMP BACK IN                         83040000
DOR3     CR    2,5                 IS INDEX TOO LARGE                   83120000
         BL    INDEXER                                                  83200000
*              GET PRODUCT OF DIMENSIONS TO THE LEFT                    83280000
         LR    1,9                 PRIME THE PRODUCT                    83360000
         LA    AX,MRHO-4(BX)       AT RHOB ABSOLUTE                     83440000
         LA    3,4                 INCREMENT                            83520000
         LR    4,3                 R4 USED AS                           83600000
DOR5     CR    4,5                 HAVE I REACHED INDEXED DIMENSION     83680000
         BNL   DOR7                YES                                  83760000
         CR    4,2                 AT END OF DIMENSION VECTOR?          83840000
         BH    DOR7                YES                                  83920000
         M     0,0(AX,4)           MULTIPLY IN NEXT DIMENSION           84000000
         BXH   0,MR,WSFULL         CHECK FOR OVERFLOW DURING MULT  2537 84080000
         BXH   4,3,DOR5            MOVE TO NEXT DIMENSION          2537 84160000
DOR7     ST    1,TBL                                                    84240000
*                                  IF CONDITION CODE IS SET = THEN      84320000
*                                  INDEX IS IN RANGE                    84400000
         LR    1,9                 RESET PRODUCT                        84480000
*                                                                       84560000
DOR8     L     5,0(AX,4)           GET SUPPRESSED DIMENSION             84640000
         ST    5,SD                                                     84720000
         AR    4,3                 SKIP SUPPRESSED DIMENSION            84800000
DOR9     CR    4,2                 ALL DIMENSIONS USED ?                84880000
         BH    DOR10               YES                                  84960000
         M     0,0(AX,4)           MULTIPLY IN NEXT DIMENSION           85040000
         BXH   0,MR,WSFULL         CHECK FOR OVERFLOW DURING MULT  2537 85120000
         BXH   4,3,DOR9            MOVE TO NEXT DIMENSION          2537 85200000
DOR10    ST    1,TBR                                                    85280000
         LR    4,5                 KEEP IT AROUND FOR LATER             85360000
         BCTR  5,0                                                      85440000
         MR    0,5                 GET DISTANCE FROM ONE                85520000
         ST    1,SBR               HYPERPLANE TO THE NEXT               85600000
         LTR   4,4                 IS SUPPRESSED DIMENSION = 0          85680000
         BNZ   DOR17               NO                                   85760000
         SR    5,5                                                      85840000
         IC    5,OPERATOR+3                                             85920000
         BAL   LKR,GETID           GET IDENTITY OF OPERATOR             86000000
DOR17    CR    4,9                 SUPPRESSED DIMENSION = 1 ?           86080000
         BNE   DOR19               NO                                   86160000
         IC    ZXR,MTYPE(BX)       SET RESULT TYPE = ARG TYPE           86240000
         STC   ZXR,RTYPE+3                                              86320000
         STC   ZXR,RCTYPE+3        SET FETCH CODE TO TYPE OF ARG        86400000
         STC   ZXR,RCFTYPE+3       BOTH PLACES                          86480000
*                                  RESULT WILL BE B WITH ONE LESS RANK  86560000
DOR19    SR    2,3                 R2 = RANK, R3 = 4                    86640000
         BNL   *+6                                                      86720000
         SR    2,2                 A SCALAR REMAINS A SCALAR            86800000
         LR    ZXR,2               KEEP RANK AROUND                     86880000
         L     3,RTYPE                                                  86960000
         LR    5,3                 KEEP TYPE AROUND                     87040000
         L     1,TBL                                                    87120000
         LTR   1,1                 CHECK FOR POSSIBLE NEGAT PROD   2537 87200000
         BM    WSFULL              BRANCH IF NEGATIVE              2537 87280000
         M     0,TBR               NUMBER OF ELEMENTS IN RESULT         87360000
         LTR   0,0                                                  A01 87440000
         BNZ   WSFULL                                               A01 87520000
         ST    1,RXRHO                                                  87600000
         L     10,=A(OPSPACE)                                           87680000
         BALR  LKR,10                                                   87760000
         STH   ZXR,MRANK(1)                                             87840000
         STC   5,MTYPE(1)                                               87920000
         ST    1,RBASE                                                  88000000
         LA    ZXR,MRHO(1)         AT RHOZ (ABSOLUTE)                   88080000
         L     BX,RHBASE           IS CASE OF GARBAGE COLLECTION        88160000
         LA    5,MRANK(BX)         AT RANK B ( ABSOLUTE)                88240000
         L     4,INDEX1                                                 88320000
         SLL   4,2                                                      88400000
         S     4,=F'4'             MAKE IT ZERO ORIGIN                  88480000
         BAL   LKR,MOVED           MOVE IN DIMENSIONS                   88560000
         LR    BX,5                POINTS TO DATA (ABSOLUTE)            88640000
         SR    ZXR,MR              MAKE POINTERS M-REL                  88720000
         SR    BX,MR                                                    88800000
         ST    BX,RHORG                                                 88880000
         ST    ZXR,RESORG                                               88960000
         L     2,RXRHO             NUMBER OF ELEMENTS                   89040000
         LTR   2,2                 ARE THERE ANY                        89120000
         BNP   DOR22               NO. THESE ARE EASY TO COMPUTE        89200000
         LA    2,0                 A DOESN'T EXIST SO FAKE GETLINK      89280000
         L     3,RCTYPE                                                 89360000
         BAL   LKR,GETL5           SKIP ANALYSIS OF A                   89440000
         L     LKR,LINKS                                                89520000
         B     4(LKR)              NORMAL RETURN                        89600000
DOR22    L     LKR,LINKS                                                89680000
         BR    LKR                 QUIT EARLY                           89760000
         SPACE 2                                                        89840000
WSFULL   LA    1,EMFULL                                             A01 89920000
         B     ER1                                                  A01 90000000
SYNTERR  LA    1,ESYNTAX                                                90080000
         B     ER1                                                      90160000
INDEXER  LA    1,EINDEX                                                 90240000
         B     ER1                                                      90320000
RANKERR  LA    1,ERANK                                                  90400000
         B     ER1                                                      90480000
CONERR   LA    1,ELENGTH                                                90560000
         B     ER1                                                      90640000
RANGERR1 LA    1,ERANGE                                                 90720000
RANGERR  EQU   RANGERR1                                                 90800000
ER1      ICALL ERROR                                                    90880000
         DROP  12                                                       90960000
*                                                                       91040000
*                                                                       91120000
         USING MATRIX+6,12                                              91200000
*              ASSUME ZX POINTS AT DATA (M-REL)                         91280000
*              ASSUMES RTYPE IS KNOWN                                   91360000
*              USES R2,R3,R9                                            91440000
SETSTORE BALR  3,0                                                      91520000
         USING *,3                                                      91600000
         L     2,RTYPE             GET RESULT TYPE                      91680000
         SR    9,9                                                      91760000
         C     2,=F'3'             IS IT FLOATING ?                     91840000
         BNE   SETST3              NO                                   91920000
         LA    9,M(ZXR)            SEE IF ON BOUNDARY                   92000000
         N     9,=F'7'                                                  92080000
         BZ    SETST3              IT IS OK                             92160000
         LA    2,5                 ITS FLT OFF BOUNDARY                 92240000
SETST3   IC    9,SETLZ-1(2)                                             92320000
         ST    9,LZ                                                     92400000
         SLL   2,2                                                      92480000
         L     2,STORE-4(2)                                             92560000
         ST    2,SRESULT                                                92640000
         BR    LKR                                                      92720000
SETLZ    DC    AL1(1,4,8,1,1)                                           92800000
*              LINKAGE TO STORE ROUTINES                                92880000
         DS    0F'0'                                                    92960000
STORE    BAL   LKR,BSTORE          STORE BOOLEAN RESULT FORM R1         93040000
STORE2   ST    1,M(9)                  STORE INTEGER RESULT FROM R1     93120000
STORE3   STD   0,M(9)                  ON BOUNDARY FLT STORE FROM F0    93200000
STORE4   BAL   LKR,CSTORE          CHAR STORE                           93280000
STORE5   BAL   LKR,FSTOREF         OFF BOUND FLT RESULT                 93360000
         DROP  3                                                        93440000
*                                                                       93520000
*                                                                       93600000
PATCH    DC    10F'0'                                                   93680000
         LTORG                                                          93760000
         EJECT                                                          93840000
OPSECT   DSECT                                                          93920000
CALC1    DS    F                   EXECUTED ENTRY POINT (INITIAL VALUE  94000000
CALC2    DS    F                   EXECUTED ENTRY FOR INNER LOOP        94080000
SRESULT  DS    F                   EXECUTED ENTRY FOR STORE ROUTINES    94160000
POSTBLOW DS    F                   EXECUTED REENTRY FOR AFTER BLOWUP    94240000
INCSTP   DS    F                   TO CONVERT RESULT OF PROD TO SCAN AR 94320000
INCSTS   DS    F                   TO CONVERT RESULT OF SCAN TO SCAN AR 94400000
AGET     DS    F                   EXECUTED TO LOAD AN ELEMENT OF LEFT  94480000
BGET     DS    F                   EXECUTED TO LOAD AN ELEMENT OF RIGHT 94560000
*              THE FOLLOWING ARE TEMP VARS USED EVERYWHERE              94640000
LINKS    DS    F                   SAVES LINK REG                       94720000
DTEMP1   DS    D                   SETUP AND FETCH                      94800000
TPROD    DS    D                                                        94880000
TPROD1   DS    D                                                        94960000
TPROD2   DS    D                                                        95040000
PRESULT  DS    D                   RESULT OF OP2                        95120000
RSAVE1   DS    2D                  RANKS AND DIMENSIONS AND MISC.       95200000
FTSAVE   DS    2D                  SAVE AREA FOR FETCH ROUTINES         95280000
LA       DS    F                   BYTE LENGTH OF AN ELEMENT OF A       95360000
LB       DS    F                   BYTE LENGTH OF AN ELEMENT OF B       95440000
LZ       DS    F                   BYTE LENGTH OF AN ELEMENT OF Z       95520000
AOP1     DS    F                   ADDRESS OF EX ROUTINE FOR OP1        95600000
OP1LFC   DS    F                   LEFT FETCH CODE                      95680000
OP1RFC   DS    F                   RT FETCH CODE                        95760000
RTYPE    DS    F                   RESULT  TYPE                         95840000
OP1CTP   DS    F                   COMPUTE TYPE                         95920000
*              LOOP VARS                                                96000000
TBL      DS    F                   PRODUCT OF DIMENSION OF B TO LEFT    96080000
TBR      DS    3F                  PRODUCT OF DIMENSIONS OF B TO RT     96160000
TBR1     EQU   TBR+4               INC TO INDEX UP A COL OF B           96240000
SBR      EQU   TBR+8                                                    96320000
AINC     DS    2F                                                       96400000
TAR      EQU   AINC+4                                                   96480000
R4SAVE   DS    F                   SAVE LOOP REG OVER OPERATOR CALL     96560000
TRZ      DS    F                                                        96640000
SD       DS    F                   SUPPRESSED DIMENSION                 96720000
SBRM1    DS    F                                                        96800000
BRT      DS    F                   DISPLACEMENT TO RTMOST ELE OF B      96880000
LASTA    DS    F                                                        96960000
LASTB    DS    F                   STOP TEST FOR LOOP                   97040000
LASTZ    DS    F                   STOP TEST FOR OLOOP                  97120000
ZPT      DS    F                                                        97200000
ZPT1     DS    F                                                        97280000
APT1     DS    F                                                        97360000
PTOSCODE DS    F                   TYPE TO CONVERT RESULT OF OP2        97440000
*                                  TO ARG TYPE OF OP1                   97520000
RTOSCODE DS    F                   FETCH TYPE TO CONVERT RESULT         97600000
*                                  OF OP1 TO ARG TYPE OF OP1            97680000
OUT      DS    F                   =0 OUTER PROD,REP--4=INNER,BASE      97760000
RPTEST   DS    F                   NONZERO IF REPRESENT  OR BASE        97840000
OLOOPS   DS    F                   LINK REG AND SAVE AREA               97920000
LOOPS    DS    F                   LINK REG AND SAVE AREA               98000000
REPIORF  DS    F                   SELECT FIXED OR FLOATING REPRESENT   98080000
REPGETA  DS    F                   FETCH A OPERAND OF REPRESENT         98160000
RREG     DS    F                   RETURN ADDRESS IN OPCTL              98240000
CALLBASE DS    F                   BASE REG OF CALLING PROG (OPCTL)     98320000
CCODE    DS    F                                                        98400000
INDEX1   DS    F                   ADJUSTED INDEX FOR REDUCE            98480000
LEND     EQU *                                                          98560000
         END                                                            98640000
./  ADD    NAME=APLSXREF
XREF     TITLE 'A P L S X R E F  APL CROSS REFERENCE MAP'               00400000
*              5734-XM6 COPYRIGHT IBM CORP.  1969, 1970                 00800000
*              5736-XM6 COPYRIGHT IBM CORP.  1969, 1970                 01200000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       01600000
         SPACE 3                                                        02000000
*                                                                       02400000
*   THIS MODULE PROVIDES A CROSS-REFERENCE MAP FOR DEBUGGING.           02800000
*   IT IS REFERENCED BY THE 'MAP' FUNCTION IN WORKSPACE '314159 OPFNS'. 03200000
*                                                                       03600000
         SPACE 1                                                        04000000
APLSXREF CSECT                                                          05200000
         DC    A(APLXREFZ-APLXREF) LENGTH OF XREF DATA             C049 05600000
APLXREF  EQU   *                                                   C049 06000000
         ENTRY APLXREF                                             C049 06400000
         DC    CL8'VERSION '                                            06800000
         DC    H'1',H'1'           VERSION 1, MOD LEVEL 1          C049 07200000
         DC    CL8'COIBM   '                                            08000000
         DC    V(COIBM)                                                 08400000
         DC    CL8'PUBENTG '                                            08800000
         DC    V(PUBENTG)                                               09200000
         DC    CL8'CONFIG  '                                            09600000
         DC    V(CONFIG)                                                10000000
         DC    CL8'PERTERMG'                                            10400000
         DC    V(PERTERMG)                                              10800000
         DC    CL8'SWAPPARS'                                            11200000
         DC    V(SWAPPARS)                                              11600000
         DC    CL8'APLSDCBS'                                            12000000
         DC    V(APLSDCBS)                                              12400000
         DC    CL8'LIBPARS '                                            12800000
         DC    V(LIBPARS)                                               13200000
         DC    CL8'CONFINIT'                                            13600000
         DC    V(CONFINIT)                                              14000000
         DC    CL8'SOFTPARS'                                            14400000
         DC    V(SOFTPARS)                                              14800000
         DC    CL8'GETSPACE'                                            15200000
         DC    V(GETSPACE)                                              15600000
         DC    CL8'ARTHTYP '                                            16000000
         DC    V(ARTHTYP)                                               16400000
         DC    CL8'EXCATEN '                                            16800000
         DC    V(EXCATEN)                                               17200000
         DC    CL8'BLOWUP  '                                            17600000
         DC    V(BLOWUP)                                                18000000
         DC    CL8'EXIOTA  '                                            18400000
         DC    V(EXIOTA)                                                18800000
         DC    CL8'DISPLAY '                                            19200000
         DC    V(DISPLAY)                                               19600000
         DC    CL8'EXRANDOM'                                            20000000
         DC    V(EXRANDOM)                                              20400000
         DC    CL8'EXRHO   '                                            20800000
         DC    V(EXRHO)                                                 21200000
         DC    CL8'DIRSEAR '                                            21600000
         DC    V(DIRSEAR)                                               22000000
         DC    CL8'EXTRAN  '                                            22400000
         DC    V(EXTRAN)                                                22800000
         DC    CL8'EXCEINTF'                                            23200000
         DC    V(EXCEINTF)                                              23600000
         DC    CL8'EXEPS   '                                            24000000
         DC    V(EXEPS)                                                 24400000
         DC    CL8'SEVERAL '                                            24800000
         DC    V(SEVERAL)                                               25200000
         DC    CL8'FFSS    '                                            25600000
         DC    V(FFSS)                                                  26000000
         DC    CL8'GOUT    '                                            26400000
         DC    V(GOUT)                                                  26800000
         DC    CL8'EXMSORT '                                            27200000
         DC    V(EXMSORT)                                               27600000
         DC    CL8'INDEX   '                                            28000000
         DC    V(INDEX)                                                 28400000
         DC    CL8'EXMMATD '                                            28800000
         DC    V(EXMMATD)                                               29200000
         DC    CL8'EXMHIST '                                            29600000
         DC    V(EXMHIST)                                               30000000
         DC    CL8'EXMIOTA '                                            30400000
         DC    V(EXMIOTA)                                               30800000
         DC    CL8'MSCOPS0 '                                            31200000
         DC    V(MSCOPS0)                                               31600000
         DC    CL8'EXMTRAN '                                            32000000
         DC    V(EXMTRAN)                                               32400000
         DC    CL8'OPEXEC  '                                            32800000
         DC    V(OPEXEC)                                                33200000
         DC    CL8'SCNSETUP'                                            33600000
         DC    V(EXRAVEL)                                               34000000
         DC    CL8'EXRAVEL '                                            34400000
         DC    V(SCNSETUP)                                              34800000
         DC    CL8'NEXTVECT'                                            35200000
         DC    V(NEXTVECT)                                              35600000
         DC    CL8'EXDCIRSL'                                            36000000
         DC    V(EXDCIRSL)                                              36400000
         DC    CL8'EXMREV  '                                            36800000
         DC    V(EXMREV)                                                37200000
         DC    CL8'SCOPS   '                                            37600000
         DC    V(SCOPS)                                                 38000000
         DC    CL8'SELECT  '                                            38400000
         DC    V(SELECT)                                                38800000
         DC    CL8'SYNTXX  '                                            39200000
         DC    V(SYNTXX)                                                39600000
         DC    CL8'ARROWS  '                                            40000000
         DC    V(ARROWS)                                                40400000
         DC    CL8'TOBCD   '                                            40800000
         DC    V(TOBCD)                                                 41200000
         DC    CL8'TYPEIN  '                                            41600000
         DC    V(TYPEIN)                                                42000000
         DC    CL8'VDOP    '                                            42400000
         DC    V(VDOP)                                                  42800000
         DC    CL8'PCSUB   '                                            43200000
         DC    V(PCSUB)                                                 43600000
         DC    CL8'HDIR    '                                            44000000
         DC    V(HDIR)                                                  44400000
         DC    CL8'APLSUP  '                                            44800000
         DC    V(APLSUP)                                                45200000
         DC    CL8'IODCON'                                         C034 45600000
         DC    V(IODCON)                                           C034 46000000
         DC    CL8'HTAB    '                                            46400000
         DC    V(HTAB)                                                  46800000
         DC    CL8'PERDEVXG'                                            47200000
         DC    V(PERDEVXG)                                              47600000
         DC    CL8'TRTABS  '                                            48000000
         DC    V(TRTABS)                                                48400000
         DC    CL8'APLOS   '                                            48800000
         DC    V(APLOS)                                                 49200000
         DC    CL8'UGHS'     CATASTROPHIC ERROR                         49600000
         DC    V(UGHS)       CATASTROPHIC ERROR                         50000000
         DC    CL8'PATCH'    PATCH AREA                                 50400000
         DC    V(PATCH)      PATCH AREA                                 50800000
APLXREFZ DC    X'FF'                                               C049 51200000
         END                                                            98400000
./  ADD    NAME=APLUBILL
BILL     TITLE 'A P L   B I L L I N G                         05/11/70' 00210000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00420000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00630000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00840000
         ENTRY APLUBILP                                                 01680000
         EXTRN APLUBILF                                                 01890000
         EXTRN APLUBILN                                                 02100000
         EXTRN CCREJ                                                    02310000
         EXTRN DIRREAD                                                  02520000
         EXTRN DIRWRT                                                   02730000
         EXTRN KMANHASH                                                 02940000
         EXTRN LOC8MAN                                                  03150000
         EXTRN OUTWRT                                                   03360000
         EXTRN OUTWRTL                                                  03570000
         EXTRN WSLOC                                                    03780000
         EXTRN PCHDCB                                                   04410000
         EXTRN UTCARDNL                                                 04620000
         PRINT OFF                 COPY APLDEFN                         05880000
         COPY  APLDEFN                                                  06090000
         TITLE 'A P L   B I L L I N G                         05/11/70' 06300000
         PRINT ON,NOGEN                                                 06510000
         DROP  11                                                       06720000
         USING M,10                                                     06930000
*                                                                       07140000
BILL     CSECT                   , PUNCH BILLING INFO                   07350000
         PROLOG                                                         07560000
         STM   12,14,DOSREGS                                            07770000
         L     1,=A(KMANHASH)                                           07980000
         L     1,0(1)                                                   08190000
         ST    1,MANHASH                                                08400000
         L     1,=A(WSLOC+4)                                            08610000
         LM    2,4,0(1)            ADDR OF WS1, WS2, AND WSLEN     2214 08820000
         LR    3,4                 PUT WSLEN IN REG 3              2214 09030000
         ST    2,BRPXLE            FIRST HALF OF WS1 IS USED AS A       09240000
*                                  BUFF FOR READING AHEAD IN BILL  2214 09450000
         SRA   3,1                 INPUT.  SECOND HALF IS USED TO       09660000
         AR    2,3                 HOLD TRACK COUNTS OF COMMON LIB WSS  09870000
         ST    2,BRPXLE+8          CHARGED TO INDIVIDUAL USERS          10080000
         LA    2,88(2)             FOR PROTECTION FROM BXLE END CONDITN 10290000
         LA    4,6                 WE CONSTRUCT A TABLE OF              10500000
         ST    2,LIBMAN            TRACKS OF WSS IS PUBLIC LIBS         10710000
         LR    5,2                 BY MAN NUMBER.  WE SEARCH ALL        10920000
         SR    2,2                 DIRECTORIES FOR PUBLIC LIBS AND ADD  11130000
         D     2,=F'170'           ITS TRACKS TO OUR TABLE.             11340000
         ST    3,HALFFULL          START, STOP CRITERION FOR BUFFERRING 11550000
         L     9,4(1)              INPUT IS BUFFER HALF FULL            11760000
         SR    9,4                 LIMIT OF TRACK COUNT TABLE           11970000
         LR    8,4                 6-BYTE ENTRIES                       12180000
         SR    0,0                                                      12390000
         SR    1,1                                                      12600000
         ST    1,DIR                                                    12810000
NEXTDIR  ICALL DIRREAD             READ A DIRECTORY                     13020000
         L     7,MANSTAR                                                13230000
         AR    7,10                                                     13440000
         USING PERLIB,7                                                 13650000
NEXTLIB  L     1,LIBNUM                                                 13860000
         C     1,ENDFLAG                                                14070000
         BE    TLASTDIR            END OF LIBS THIS DIRECTORY           14280000
         C     1,=F'1000'                                               14490000
         BNL   FIXLIBAD            NOT A COMMON LIBRARY                 14700000
         L     2,LIBLINK                                                14910000
TST1     LTR   2,2                                                      15120000
         BZ    FIXLIBAD                                                 15330000
         AR    2,10                                                     15540000
         L     3,LIBMAN            SCAN TABLE FOR THIS MANNO            15750000
         B     TLASTMAN                                                 15960000
NEXTMAN  CLC   0(4,3),PSMAN-PERSAVW(2)                                  16170000
         BNE   TLASTMAN                                                 16380000
         SR    0,0                                                      16590000
         IC    0,PSLEN-PERSAVW(2)                                       16800000
         AH    0,4(3)              MANNO FOUND, ADD TRKCOUNT            17010000
         STH   0,4(3)                                                   17220000
         B     TLASTPSV                                                 17430000
TLASTMAN BXLE  3,4,NEXTMAN                                              17640000
         BXH   5,8,OVFLTBL         NOT FOUND, MAKE NEW ENTRY            17850000
         MVC   0(4,5),PSMAN-PERSAVW(2)                                  18060000
         MVC   5(1,5),PSLEN-PERSAVW(2)                                  18270000
         MVI   4(5),0                                                   18480000
TLASTPSV L     2,PSLINK-PERSAVW(2)                                      18690000
         B     TST1                                                     18900000
FIXLIBAD LA    7,MANENTL(7)                                             19110000
         B     NEXTLIB                                                  19320000
TLASTDIR L     1,DIR                                                    19530000
         LA    1,1(1)                                                   19740000
         ST    1,DIR                                                    19950000
         C     1,MANHASH                                                20160000
         BL    NEXTDIR                                                  20370000
         L     3,LIBMAN                                                 20580000
         AR    3,4                                                      20790000
         STM   3,5,TBLCNTR                                              21000000
         B     DOBILLS                                                  21210000
OVFLTBL  ICALL OUTWRTL             TABLE TOO LARGE LOG MESSAGE          21420000
         DC    AL4(OVFLMSG)                                             21630000
         B     DOBILLS                                                  21840000
DIR      DS    F                                                        22050000
LIBMAN   DS    A                                                        22260000
TBLCNTR  DS    3A                                                       22470000
ENDFLAG  DC    X'FFFFFFFF'                                              22680000
OVFLMSG  DC    C'TRACK COUNTS FROM COMMON LIBRARIES ARE INCOMPLETE'     22890000
         DC    X'FF'                                                    23100000
DOBILLS  MVI   BRCOM,0             INITIALIZE FOR MAIN PART OF PROGRAM  23310000
         MVI   BPCOM,0                                                  23520000
         MVI   FBI,0                                                    23730000
         MVI   BRDGO,1                                                  23940000
         MVI   PSWITCH,0           INITIALIZE EXIT FRON BPUNCH          24150000
         LM    1,3,BRPXLE          MARK ALL AREAS UNOCCUPIED            24360000
BCI1     MVI   0(1),0                                                   24570000
         BXLE  1,2,BCI1                                                 24780000
*              THE COMMUTATOR                                           24990000
BIL1     BAL   LKR,BREAD           READ A CARD OR DON'T                 25200000
BIL2     BAL   LKR,BPUNCH          PUNCH A CARD OR DON'T                25410000
TSTEND   CLI   BRCOM,0                                                  27090000
         BE    BIL1                NOT FINISHED READING                 27300000
         CLI   BPCOM,0                                                  27510000
         BE    BIL2                NOT FINISHED PUNCHING                27720000
         CLI   FBI,1                                                    27930000
         BE    BIL2                                                     28140000
         MVI   FBI,1                                                    28350000
         LA    13,SAVREG1                                               28560000
         L     15,=A(APLUBILF)     MAKE SURE INST ROUTINE IS DEFINED    28770000
         LTR   15,15                                                    28980000
         BZ    NOUINST                                                  29190000
         CALL  (15),(BLANK,MONES)  SIGNAL INSTALLATION FORMATTING       29400000
*                                   ROUTINE THAT WE ARE DONE.           29610000
         LA    1,ENDPARM           ADDRESS OF BLANK CARD                29820000
         LA    13,SAVREG1                                               30030000
         L     15,=A(APLUBILP)                                          30240000
         BALR  14,15                                                    30450000
         LM    13,14,DOSREGS+4                                          30660000
BILX     L     1,WFLMAN-M(10)                                           30870000
         ICALL DIRWRT                                                   31080000
         IRETURN                                                        32130000
MANHASH  DC    F'0'                                                     34020000
BRPXLE   DC    A(0,85,0)                                                34230000
ENDPARM  DC    A(BLANK),X'80',AL3(MONES)                                34440000
*                                                                       34650000
*                                                                       34860000
*                                                                       35070000
*              POSSIBLY READ A CARD.  SET BRCOM IF END FILE.            35280000
BREAD    ST    LKR,BRLINK                                               35490000
         CLI   BRCOM,0                                                  36750000
         BCR   7,LKR               PREVIOUS END FILE                    36960000
         L     1,BRCCW                                                  37170000
         N     1,=A(X'FFFFFF')                                          37380000
         BZ    BREAD2              LAST CARD READ WAS PROCESSED PREVIOU 37590000
         BCTR  1,0                 'COLUMN 0' IS BUFFER OCCUPANCY CODE  37800000
         LR    4,1                                                      38010000
         MVC   BRCCW(8),BRDCW      CLEAR ADDRESS OF CCW                 38220000
         LA    2,1                                                      39900000
         LA    3,79(1)                                                  40110000
BREAD5   CLI   1(1),C' '                                                40320000
         BNE   BREAD6                                                   40530000
         BXLE  1,2,BREAD5                                               40740000
BREAD6   CLC   1(4,1),=C'END '                                          40950000
         BE    BREAD4                                                   41160000
         MVI   0(4),X'FF'          SET BUFFER OCCUPANCY FLAG            41370000
         MVC   81(4,4),=F'0'       MARK MAN NUMBER UNSCANNED            41580000
BREAD2   LM    1,3,BRPXLE          LOOK FOR UNOCCUPIED BUFFER AREA      41790000
         SR    4,4                 INIT COUNT OF FREE BUFFERS           42000000
BREAD1   CLI   0(1),0                                                   42210000
         BNE   BREAD3              OCCUPIED                             42420000
         LA    4,1(4)              FOUND.  UP COUNT OF FREE BUFFERS     42630000
         LA    5,1(1)                                                   42840000
         CLI   BRDGO,0             IF IN A READING MOOD, CONTINUE       43050000
         BNE   BREAD8                                                   43260000
BREAD3   BXLE  1,2,BREAD1                                               43470000
         MVI   BRDGO,0             NOT IN READ CYCLE ANYMORE            43680000
         C     4,HALFFULL          UNLESS OVER THE THRESHOLD            43890000
         BCR   4,LKR  BL           NOT                                  44100000
         MVI   BRDGO,1             READING CYCLE AGAIN                  44310000
BREAD8   A     5,BRDCW             CCW ADDRESS FIELD AND COMMAND        44520000
         ST    5,BRCCW                                                  44730000
         LR    1,5                                                      45990000
         SR    0,0                                                      46200000
         ICALL UTCARDNL                                                 46410000
         B     BREAD4                                                   46620000
BREAD9   L     LKR,BRLINK                                               47040000
         BR    LKR                                                      47250000
BREAD4   MVI   BRCOM,X'FF'         DONE READING                         48510000
         B     BREAD9                                                   48720000
BRCCW    CCW   X'02',0,X'20',80                                         49770000
BRDCW    CCW   X'02',0,X'20',80                                         49980000
BRCOM    DS    XL1                 READ COMPLETE FLAG                   50190000
BRDGO    DS    XL1                                                      50400000
*                                                                       50610000
*              MAYBE PUNCH A CARD OR TWO OR READ OR WRITE THE DISK      50820000
BPUNCH   ST    LKR,BPLINK                                               51030000
         MVC   BPCOM(1),BRCOM      IF EXIT WITHOUT PUNCHING CARDS,      52710000
*                                  PUNCHING COMPLETED IFF READING COMPL 52920000
         LM    5,7,BRPXLE                                               53130000
         SR    8,8                 INIT COUNT OF BUFFERS IN USE         53340000
BPUNCH2  CLI   0(5),0               SEARCH FOR FILLED BUFFER BELONGING  53550000
*                                  TO CURRENT DIRECTORY.                53760000
         BE    BPUNCH1                                                  53970000
         LA    8,1(8)              UP COUNT OF BUFFERS IN USE           54180000
         MVC   INBUF(84),1(5)      MOVE BUFFER TO INTERFACE AREA        54390000
         L     1,FMANNO            WE MAY HAVE SCANNED THIS CARD BEFORE 54600000
         ST    1,MANNO                                                  54810000
         LTR   1,1                                                      55020000
         BNZ   BPUNCH3             AVOID PRESENTING CARD TO USER CODE   55230000
*                                  MORE THAN ONCE                       55440000
         LA    13,SAVREG1          SAVE AREA                            55650000
         L     15,=A(APLUBILN)     MAKE SURE INST ROUTINE IS DEFINED    55860000
         LTR   15,15                                                    56070000
         BZ    NOUINST                                                  56280000
         CALL  (15),(INBUF,MANNO)  GET MAN NUMBER                       56490000
         LM    13,14,DOSREGS+4                                          56700000
         MVC   1(80,5),INBUF       MOVE CARD IMAGE BACK TO BUFFER       56910000
         MVC   81(4,5),MANNO       ASSOCIATE SCANNED NO. WITH CARD IMAG 57120000
         L     1,MANNO                                                  57330000
         LTR   1,1                                                      57540000
         BZ    BILREJ              ZERO MANNO MEANS INVALID CARD        57750000
         BM    BILREJ2             NEGATIVE MEANS REJECT QUIETLY        57960000
BPUNCH3  MVI   BPCOM,0                                                  58170000
         SR    0,0                                                      58380000
         D     0,MANHASH                                                58590000
         ST    0,SAVDIR                                                 58800000
         C     0,WFLMAN-M(10)                                           59010000
         BNE   BPUNCH1             RIGHT DIRECTORY                      59220000
         MVI   0(5),0              MARK NONOCCUPANCY                    59430000
         L     0,MANNO                                                  59640000
         ICALL LOC8MAN                                                  59850000
         B     BILNF                                                    60060000
         MVC   CONN(8),CUMCON-PERLIB(1)                                 60270000
         XC    CUMCON-PERLIB(8,1),CUMCON-PERLIB(1) RESET TIMES          60480000
         MVC   BILNAME(12),HISNAME-PERLIB(1)                            60690000
         MVC   BILWSQ(2),MANWSQ-PERLIB(1)                               60900000
         MVC   BILWSA(2),MANWSA-PERLIB(1)                               61110000
         L     2,LIBLINK-PERLIB(1) SCAN PERSAVW'S TO ACCUMULATE         61320000
         SR    6,6                 TRKCOUNT                             61530000
         SR    4,4                                                      61740000
TST      LTR   2,2                                                      61950000
         BZ    ALLPSVW                                                  62160000
         AR    2,10                                                     62370000
         IC    6,PSLEN-PERSAVW(2)                                       62580000
         AR    4,6                                                      62790000
         L     2,PSLINK-PERSAVW(2)                                      63000000
         B     TST                                                      63210000
ALLPSVW  STH   4,WSTRACKS                                               63420000
         LM    3,5,TBLCNTR         SCAN TABLE OF TRKCOUNTS FROM         63630000
NEXTENT  CLC   MANNO(4),0(3)       COMMON LIBRARYS AND ADD INTO         63840000
         BNE   TESTMAN             TRKCOUNT IF MANNO IS MATCHED         64050000
         LH    6,WSTRACKS                                               64260000
         AH    6,4(3)                                                   64470000
         STH   6,WSTRACKS                                               64680000
         B     CALLF                                                    64890000
TESTMAN  BXLE  3,4,NEXTENT                                              65100000
CALLF    LA    13,SAVREG1                                               65310000
         L     15,=A(APLUBILF)     MAKE SURE INST ROUTINE IS DEFINED    65520000
         LTR   15,15                                                    65730000
         BZ    NOUINST                                                  65940000
         CALL  (15),(INBUF,BILINFO) DO ACCOUNTING                       66150000
         LM    13,14,DOSREGS+4                                          66360000
BPUNCHR  L     LKR,BPLINK                                               66570000
         BR    LKR                                                      66780000
BPUNCH1  BXLE  5,6,BPUNCH2         KEEP LOOKING FOR CARD IN THIS DIR    66990000
         L     LKR,BPLINK          NONE                                 67200000
         CLI   BPCOM,0                                                  67410000
         BCR   7,LKR               REALLY DONE                          67620000
         C     8,HALFFULL          IF BUFFER IS RELATIVELY EMPTY,       67830000
         BNL   BPCH4                                                    68040000
         CLI   BRCOM,0             DON'T DO DIRECTORY READ UNLESS       68250000
         BCR   8,LKR               BREAD REACHED END OF FILE            68460000
BPCH4    L     1,WFLMAN-M(10)      GET SOME OTHER DIRECTORY             68670000
         ICALL DIRWRT                                                   68880000
         L     1,SAVDIR                                                 69090000
         ICALL DIRREAD                                                  69300000
         B     BPUNCHR                                                  69510000
*                                                                       69720000
* APLUBILP.....PUNCHING ROUTINE CALLED BY APLUBILF.  INCLUDES ERROR     69930000
*              RECOVERY.  RETURNS TO THE COMMUTATOR DIRECTLY TO         70140000
*              AWAIT COMPLETION OF THE PUNCHING                         70350000
APLUBILP SAVE  (14,12)                                                  70560000
         CNOP  2,4   ASSEMBLER WILL FLAG US IF WE ARE NOT CAREFUL       70770000
         BALR  12,0                RESTORE ADDRESSABILITY               70980000
         ST    13,SAVE13-*(12)                                          71190000
         LM    12,14,DOSREGS-(*-4)(12)                                  71400000
         L     0,0(1)                                                   76440000
         STM   13,15,R13SAVE                                            76650000
         LA    13,OSSAVE                                                76860000
         L     1,=A(PCHDCB)                                             77070000
         PUT   (1),(0)                                                  77280000
         LM    13,15,R13SAVE                                            77490000
         BAL   LKR,BREAD                                                77910000
         L     13,SAVE13                                                78120000
         RETURN (14,12)                                                 78330000
*              ERROR CONDITIONS                                         78540000
BILNF    NOP   BILNF1              FIRST TIME ONLY, PRINT WARNING       78750000
         OI    BILNF+1,X'F0'       ON SYSLOG                            78960000
         ICALL OUTWRTL                                                  79170000
         DC    AL4(NFMSG)                                               79380000
BILNF1   MVC   NUMB(4),MANNO                                            79590000
         ICALL OUTWRT                                                   79800000
         DC    AL4(BILNTX)                                              80010000
         B     BPUNCHR                                                  80220000
BILREJ   NOP   BILREJ1             FIRST TIME ONLY, PRINT WARNING       80430000
         OI    BILREJ+1,X'F0'      ON SYSLOG                            80640000
         ICALL OUTWRTL                                                  80850000
         DC    AL4(WRNMSG)                                              81060000
BILREJ1  MVC   REJCRD(80),1(5)                                          81270000
         ICALL OUTWRT                                                   81480000
         DC    AL4(REJMSG)                                              81690000
BILREJ2  MVI   0(5),0              UNOCCUPY THE BUFFER                  81900000
         B     BPUNCH1                                                  82110000
*                                                                       82320000
NOUINST  LM    12,14,DOSREGS                                            82530000
         ICALL OUTWRTL             NO INSTALLATION ROUTINE DEFINED      82740000
         DC    AL4(NOUIMSG)                                             82950000
         ICALL CCREJ                                                    83160000
BPCOM    DS    XL1                                                      83370000
FBI      DS    CL1                                                      83580000
PSWITCH  DS    XL1                                                      83790000
BRLINK   DS    F                                                        84000000
R13SAVE  DS    3F                                                       84630000
OSSAVE   DS    18F                                                      84840000
BPLINK   DS    A                   BPUNCH LINK                          85260000
HALFFULL DS    F                   NO. OF CARD IMAGES THAT HALF FILL    85470000
*                                  THE READ BUFFER                      85680000
INBUF    DS    10D                                                      85890000
FMANNO   DS    F                   USER-SCANNED MAN NO.                 86100000
SAVE13   DS    F                                                        86310000
         DS    0D                                                       86520000
MANNO    DS    F                   MAN NUMBER                           86730000
         DS    0D                                                       86940000
*                                  ACCOUNTING INFORMATION               87150000
CONN     DS    F                                                        87360000
CPU      DS    F                   COMPUTE TIME IN SECONDS/300          87570000
BILNAME  DS    CL12                SIGN ON NAME                         87780000
BILWSQ   DS    H                   WORKSPACE QUOTA                      87990000
BILWSA   DS    H                   ACTUAL NUMBER OF WS                  88200000
WSTRACKS DS    H                   TOTAL TRACKS FOR ALL WS              88410000
         DS    5H                  RESERVED FOR BACKING STORE           88620000
BILINFO  EQU   CONN                                                     88830000
BILINFOL EQU   *-BILINFO                                                89040000
SAVREG1  DS    9D                                                       89250000
DOSREGS  DS    3F                                                       89460000
SAVDIR   DS    F                                                        89670000
TIMES    DC    D'0'                                                     91350000
WORK     DC    D'0'                                                     91560000
BILNTX   DC    C'USER NOT IN SYSTEM   '                                 91770000
         DC    X'10'                                                    91980000
NUMB     DC    XL4'00'                                                  92190000
         DC    X'FF'                                                    92400000
REJMSG   DC    C'REJECTED BILLING INPUT  '                              92610000
REJCRD   DS    CL80                                                     92820000
         DC    X'FF'                                                    93030000
WRNMSG   DC    C'REJECTED BILLING INPUT APPEARS ON SYSLST'              93240000
         DC    X'FF'                                                    93450000
NFMSG    DC    C'USER NUMBERS NOT IN SYSTEM APPEAR ON SYSLST'           93660000
         DC    X'FF'                                                    93870000
NOUIMSG  DC    C'NO INSTALLATION ROUTINE - BILLING TERMINATED',X'FF'    94080000
BILBF1   DS    CL80                                                     94290000
BILBF2   DS    CL80                                                     94500000
         DS    0D                                                       94710000
BLANK    DC    80C' '                                                   94920000
MONES    DC    (BILINFOL)X'FF'                                          95130000
         LTORG                                                          95340000
         COPY  DIRSECT                                                  95550000
         END                                                            95760000
./  ADD    NAME=APLUDISK
DISK     TITLE 'APL UTILITY DISK I/O ROUTINES                 05/11/70' 00070000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00140000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00210000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00280000
DISKSECT CSECT                                                          00560000
         PRINT OFF                 COPY APLDEFN ZSYMBOLS                00630000
EMPTYM   EQU   X'80'                                               5989 00700000
         COPY APLDEFN                                                   00770000
         TITLE 'INITIALIZE WS POINTERS AND COMPUTE MAX/CFREDSK'         00840000
DISKSECT CSECT                                                          00910000
         COPY  ZSYMBOLS                                                 00980000
         PRINT ON                                                  C037 01050000
*        RE-INITIALIZE WS POINTERS AND COMPUTE CFREDSK                  01120000
*                                                                       01190000
DIRSET   PROLOG                                                         01260000
         ENTRY DIRSET                                                   01330000
         L     1,=A(KMANHASH)                                           01400000
         L     1,0(1)                                                   01470000
         ST    1,MANHASH           INITIALIZE THE NUMBER OF DIRECTORIES 01540000
         L     10,=A(WSLOC)                                             01610000
         L     10,0(10)                                                 01680000
         DROP 11                                                        01750000
         USING M,10                                                     01820000
         SR    1,1                                                      01890000
* CFREDSK FOR EACH EXTENT IS MAX / FREEDSK FOR EACH LIBRARY             01960000
DSET2    STH   1,DIRIN                                                  02030000
         ICALL DIRREAD                                                  02100000
         LM    0,2,CDCBXLE                                              02170000
         USING CDCPARS,2                                                02240000
         LA    3,FREEDSK                                                02310000
DIRLP3   CLC   CFREDSK,0(3)                                             02380000
         BH    DIRLP4                                                   02450000
         MVC   CFREDSK,0(3)                                             02520000
DIRLP4   LA    3,4(3)                                                   02590000
         BXLE  2,0,DIRLP3                                               02660000
         DROP  2                                                        02730000
         LH    1,DIRIN                                                  02800000
         LA    1,1(1)                                                   02870000
         C     1,MANHASH                                                02940000
         BL    DSET2                                                    03010000
*        CFREDSK IS INITIALIZED                                         03080000
         IRETURN                                                        03150000
         DROP  10                                                       03220000
         LTORG                                                     C059 03290000
         TITLE 'LIBRARY DISK USAGE SUMMARY'                             03360000
*                                                                       03430000
*        PRINT LAST CYLINDER IN USE, ALL LIBRARY PACKS ON SYSLOG        03500000
*                                                                       03570000
LCYLOG   PROLOG                                                         03640000
         ENTRY LCYLOG                                                   03710000
         LM    2,4,CDCBXLE                                              03780000
         USING CDCPARS,4                                                03850000
         SR    5,5                                                      03920000
LCY1     LH    6,EXTLOW                                                 03990000
         LH    7,EXTUP                                                  04060000
         SR    7,6                                                      04130000
         LA    7,1(7)                                                   04200000
         ST    7,LCYDT                                                  04270000
         MVC   DRMC+1(4),LCYDT                                          04340000
         LH    7,CFREDSK                                                04410000
         SR    7,6                                                      04480000
         ST    7,DRMSG+1                                                04550000
         MVC   DRMS3(44),DSLAB                                          04620000
         ICALL OUTWRTL                                                  04690000
         DC    AL4(DRMSG)                                               04760000
         LA    5,1(5)                                                   04830000
         BXLE  4,2,LCY1                                                 04900000
*        PRINT +/ SALVHED, ALL DIRECTORIES.                             04970000
         L     9,=A(KMANHASH)                                           05040000
         L     9,0(9)                                                   05110000
         ST    9,LCYHASH                                                05180000
         SR    1,1                                                      05250000
         ST    1,LCYTRKS                                                05320000
LCY2     ICALL DIRREAD                                                  05390000
         USING M,10                                                     05460000
         LA    3,SALVHED                                                05530000
         LA    4,4                                                      05600000
         LA    5,FREEDSK-1                                              05670000
         USING PERSAVW,2                                                05740000
LCY3     L     2,0(3)                                                   05810000
LCY4     LTR   2,2                                                      05880000
         BZ    LCYBXLE                                                  05950000
         AR    2,10                                                     06020000
         SR    1,1                                                      06090000
         IC    1,PSLEN                                                  06160000
         A     1,LCYTRKS                                                06230000
         ST    1,LCYTRKS                                                06300000
         L     2,PSLINK                                                 06370000
         B     LCY4                                                     06440000
LCYBXLE  BXLE  3,4,LCY3                                                 06510000
         L     1,WFLMAN-M(10)                                           06580000
         LA    1,1(1)                                                   06650000
         C     1,LCYHASH                                                06720000
         BL    LCY2                                                     06790000
         MVC   TRKS+1(4),LCYTRKS                                        06860000
         ICALL OUTWRTL                                                  06930000
         DC    AL4(TRKS)                                                07000000
         IRETURN                                                        07070000
LCYDT    DC    D'0'                                                     07140000
LCYHASH  EQU   LCYDT                                                    07210000
LCYTRKS  EQU   LCYDT+4                                                  07280000
TRKS     DC    X'1000000000'                                            07350000
         DC    C' SALVAGED TRACKS'                                      07420000
         DC    X'FF'                                                    07490000
         DC    0F'0',CL3' '        PUT ON 3RD BYTE OF FULLWORD          07560000
DRMSG    DC    X'100000'                                                07630000
         DC    X'0000'                                                  07700000
         DC    C' OF '                                                  07770000
DRMC     DC    X'100000'                                                07840000
         DC    X'0000'                                                  07910000
         DC    C' CYLS, '                                               07980000
DRMS3    DC    CL44' ',X'FF'                                            08050000
*                                                                       08120000
         DROP  2,10                                                     08190000
         DROP  4,12                                                     08260000
*                                                                       08330000
*        LOG DAMAGED WORKSPACE NAMES                                    08400000
*              R0 = TIMESTAMP ADDRESS, OR 0                             08470000
*              R1 = WSID ADDRESS                                        08540000
*              R2 = ACTION TEXT (9 BYTES)                           A04 08610000
*                                                                       08680000
         ENTRY DWSLOG                                                   08750000
DWSLOG   PROLOG                                                         08820000
         MVI   DLTS-6,C' '         ASSUME NO TIMESTAMP                  08890000
         MVC   DLTS-5(17),DLTS-6                                        08960000
         MVC   DLMACT(9),0(2)      MOVE ACTION INTO MSG             A04 09030000
         LTR   2,0                                                      09100000
         BZ    DL2                                                      09170000
         MVC   DLTS-6(6),=X'000000000013'  MOVE IN TIMESTAMP STARTER    09240000
         MVC   DLTS(12),0(2)       AND TIMESTAMP                        09310000
DL2      MVC   DLID(16),0(1)                                            09380000
         MVC   DLSNAP(9),0(3)      MOVE SNAPID OR X'FF' TO MSG          09520000
         NOP   DL3                 FIRST-TIME SWITCH                    09660000
         OI    *-3,X'F0'                                                09730000
         ICALL OUTWRTL                                                  09800000
         DC    AL4(DLMSG1)                                              09870000
DL3      ICALL OUTWRT                                                   09940000
         DC    AL4(DLMSG2)                                              10010000
         IRETURN                                                        10080000
DLMSG1   DC    C'NAMES OF DAMAGED WORKSPACES APPEAR ON SYSLST',X'FF'    10150000
DLMSG2   DC    C'WORKSPACE DAMAGED '                                A04 10220000
DLMACT   DC    CL10'XXXXXXXXX '                                     A04 10290000
         DC    XL6'00'                                                  10360000
DLTS     DC    XL12'00'                                                 10430000
         DC    X'11'                                                    10500000
DLID     DC    XL16'00'                                                 10570000
         DC    C' '                                                     10710000
DLSNAP   DC    CL9'XXXXXXXXX'      SNAPID FOR OS WSDUMP                 10780000
         DC    X'FF'                                                    10920000
         TITLE 'FORMAT AND VERIFY DISK ROUTINES'                        10990000
*                                                                       11060000
*        FORMAT DISK DESIGNATED BY (PARAMS+4)                           11130000
*                                                                       11200000
FMTDSK   PROLOG                                                         11270000
         ENTRY FMTDSK                                                   11340000
         L     1,=A(PARAMS)                                             11410000
         L     1,4(1)                                                   11480000
         MH    1,CDCBXLE+2                                              11550000
         A     1,ADPAR                                                  11620000
         C     1,CDCBXLE+4                                              11690000
         BNL   FMTXXX              CHECK FOR PARAMETER OUT OF RANGE     11760000
         ST    1,FMTPARS+4                                              11830000
         LA    1,FMTPARS                                                11900000
         ICALL DISKFMT                                                  11970000
         IRETURN                                                        12040000
         SPACE                                                          12110000
FMTXXX   ICALL OUTWRTL             PARAMETER OUT OF RANGE.              12180000
         DC    AL4(XXXMSG)                                              12250000
         ICALL CCREJ               RETURN, REQUEST INPUT FROM SYSLOG    12320000
         SPACE                                                          12390000
FMTPARS  DC    F'0'                NONSWAP                              12460000
         DC    A(*-*)                                                   12530000
         DC    F'0'                                                     12600000
         DC    A(0,0)                                                   12670000
         SPACE 2                                                        12740000
*              READ WITH SKIP ALL TRACKS IN EXTENT (UP TO CFREDSK)      12810000
VERIFY   PROLOG                                                         12880000
         ENTRY VERIFY                                                   12950000
         L     4,=A(PARAMS)                                             13020000
         L     4,4(4)                                                   13090000
         MH    4,CDCBXLE+2                                              13160000
         A     4,ADPAR                                             3580 13230000
         C     4,CDCBXLE+4         CHECK FOR PARAMETER IN RANGE    3580 13300000
         BNL   VERXXX                                              3580 13370000
         USING CDCPARS,4                                                13440000
         MVC   VERSK+2(4),EXTLOW                                        13790000
         MVC   VERCWR+6(2),TLENF+2                                      13860000
         MVI   VERPSCCW,NOP        RESET TO NO-OP                  DASD 14000000
         TM    CDCFLAGS,RPS        WAS RPS SELECTED                DASD 14070000
         BZ    VER4                NO                              DASD 14140000
         MVI   VERPSCCW,SETSECTR   MOVE IN SET SECTOR COMMAND      DASD 14210000
VER4     LA    2,10                ERROR RETRY COUNT                    14350000
         LA    3,IOB                                                    15190000
         USING IOBECB,3                                                 15260000
         LH    1,LOGAD         LOAD INDEX OF DCB                        15330000
         MH    1,=H'72'            MULTIPLY BY LENGTH                   15400000
         A     1,=A(APLSDCBS)      ADD BASE                             15470000
         ST    1,IOBDCB            STORE IN IOB                         15540000
         MVC   IOBFLAG1(2),=X'C200' CC+DC+SYNCHRONOUS WAIT.             15610000
         MVC   IOBSTART(3),=AL3(VERCW) CCW CHAIN START ADDRESS.         15680000
         MVC   IOBERRCT(2),=H'0'   ZERO ERROR COUNT.                    15750000
         MVC   IOBSKPT(7),VERSK       MOVE SEEK ADDRESS TO IOB          15820000
VER1A    XC    EVNTCB(4),EVNTCB    ZERO OUT EVENT CONTROL BLOCK.        15890000
         DROP  3                                                        15960000
VER1     EXCP  IOB                                                      16030000
         WAIT  ECB=ECB                                                  16100000
         LA    1,IOB                                                    16170000
         USING IOBECB,1                                                 16240000
         CLI   ECB,X'7F'           CHECK ENDING STATUS FOR ERRORS.      16310000
         BNE   VER3A                                                    16380000
         CLC   IOBSTAT(2),=X'0C00' CHECK CSW STATUS FOR NORM END        16450000
         BE    VER2                 TRACK OK                            16520000
VER3A    TM    IOBSENS1,NRF        NO RETRIES UNLESS               3581 16590000
         BZ    VER3                IT'S NO RECORD FOUND            3581 16660000
NRF      EQU   X'08'               NO RECORD FOUND                 3581 16730000
         DROP  1                                                        16800000
         BCT   2,VER1A             RETRY 10 TIMES                  3581 16870000
VER3     MVC   VERMCH,VERSK+2                                           17010000
         MVC   VERMSU(44),DSLAB                                         17080000
         ICALL OUTWRTL                                                  17150000
         DC    AL4(VERMSG)                                              17220000
VER2     LA    1,1                                                      17290000
         A     1,VERSK+2                                                17360000
         ST    1,VERSK+2                                                17430000
         CLC   VERSK+4(2),HMAX                                          17500000
         BL    VER5                                                     17570000
         A     1,CCADJ                                                  17640000
         ST    1,VERSK+2                                                17710000
VER5     CL    1,EXTUP                                                  17780000
         BL    VER4                                                     17850000
         IRETURN                                                        17920000
         SPACE                                                          17990000
VERXXX   ICALL OUTWRTL             PARAMETER OUT OF RANGE               18060000
         DC    AL4(XXXMSG)                                              18130000
         ICALL CCREJ               RETURN, REQUEST INPUT FROM SYSLOG    18200000
         SPACE                                                          18270000
XXXMSG   DC    C'LIBRARY EXTENT PARAMETER OUT OF RANGE'                 18340000
         DC    X'FF'                                                    18410000
         SPACE                                                          18480000
VERCW    CCW   X'07',VERSK,X'40',6                                      18830000
VERPSCCW CCW   SETSECTR,ZERO,CC,1  WILL BE A NO-OP IF RPS NOT USED DASD 18970000
         CCW   X'31',VERSK+2,X'40',5                                    19110000
         CCW   X'08',*-8,0,0                                            19180000
VERCWR   CCW   X'06',*,X'10',0                                          19250000
         CNOP  2,4                                                      19320000
VERSK    DC    XL7'00000000000001'                                      19390000
VERMSG   DC    C'BAD TRACK '                                            19460000
         DC    X'04'                                                    19530000
VERMCH   DC    XL4'00'                                                  19600000
         DC    C', '                                                    19670000
VERMSU   DC    CL44' ',X'FF'                                            19740000
         DROP  4                                                        19810000
         TITLE 'START A SEEK OPERATION (USED BY INCDUMP)  '             19880000
*                                                                       19950000
*        SEEK TO CCHH IN R1 ON FILE NUMBER R2/CDCL                 DASD 20020000
         ENTRY DSEEK                                                    20090000
DSEEK    PROLOG                                                         20160000
         STM   1,2,DSSKT                                                20230000
         WAIT  ECB=ECB                                                  20650000
         MVC   DSSKAD+2(4),DSSKT                                   DASD 20790000
         A     2,ADPAR             R2 WAS OFFSET INTO DISKPARS TABLE    20860000
         USING   CDCPARS,2                                              21350000
         LA    3,IOB                                                    21420000
         USING  IOBECB,3                                                21490000
         LH    1,LOGAD             PUT DCB ADDR IN IOB                  21560000
         MH    1,=H'72'        MULTIPLY BY LENGTH                       21630000
         A     1,=A(APLSDCBS)      ADD BASE                             21700000
         ST    1,IOBDCB                                                 21770000
         MVC   IOBFLAG1(2),=X'C200'  CC+DC+SYNCHRONOUS WAIT             21840000
         MVC   IOBSTART(3),=AL3(DSSKCW)  CCW CHAIN START ADDR           21910000
         MVC   IOBERRCT(2),=H'0'     ZERO ERROR COUNT                   21980000
         MVC   IOBSKPT(6),DSSKAD   MOVE SEEK ADDR TO IOB                22050000
         XC    EVNTCB(4),EVNTCB      ZERO OUT ECB                       22120000
         DROP  3,2                                                      22190000
         EXCP IOB                                                       22260000
         LM    1,2,DSSKT                                                22400000
         IRETURN                                                        22470000
*                                                                       22540000
DSSKT    DC    2F'0'               TEMP STORAGE                         22610000
DSSKCW   CCW   X'07',DSSKAD,X'20',6                                     22960000
DSSKAD   DC    XL6'00'                                                  23030000
         TITLE 'DISK READ ROUTINE'                                      23100000
*                                                                       23170000
*                                                                       23240000
*                                                                       23310000
*        READ WORKSPACE FROM CYLINDER, HEAD IN R1 TO CORE AREA DESIG-   23380000
*        NATED BY R11.                                                  23450000
*        R2 IS FILE NUMBER * CDCL                                       23520000
*                                                                       23590000
DRD      PROLOG                                                         23660000
         ENTRY DRD                                                      23730000
         ICALL DRDR1               READ FIRST RECORD,                   23800000
         ICALL DRDREST             THEN WITH CDCOMP'S HELP, READ REST.  23870000
         IRETURN                                                        23940000
         SPACE 2                                                        24010000
         ENTRY DRDR1                                                    24080000
DRDR1    PROLOG                                                         24150000
         STM   1,6,DWRT                                                 24220000
         L     1,=A(WSLEN)         WORKSPACE LENGTH.                    24290000
         L     1,0(1)                                                   24360000
         ST    1,WLEN                                                   24430000
         A     2,ADPAR                                                  24500000
         ST    2,CDCBASE                                                24570000
         ICALL DRDZ                                                     24920000
         LA   15,WLEN         ADDRESSIBILITY                       5989 24990000
         USING WLEN,15                                             5989 25060000
         MVC   PHYCYL,DWRT         SET UP PARAMETERS FOR CDCOMP    DASD 25130000
         L     3,RD1ST                                                  25690000
         MVC   2(4,3),PHYCYL                                       DASD 25760000
         DROP  15                                                  5989 25830000
         ST    11,DWRT             AND FOR RECORD 1 CCW CHAIN           25900000
         MVC   CDCAD+1(3),DWRT+1                                        25970000
         LA    3,IOB                                                    26460000
         USING IOBECB,3                                                 26530000
         L     1,CDCBASE                                                26600000
         MVI   RPSCCW,NOP          RESET TO NO-OP                  DASD 26670000
         TM    CDCFLAGS-CDCPARS(1),RPS SHOULD RPS BE USED          DASD 26740000
         BZ    DRNORPS             NO                              DASD 26810000
         MVI   RPSCCW,SETSECTR     MOVE IN SET SECTOR COMMAND      DASD 26880000
DRNORPS  EQU   *                                                   DASD 26950000
         LH    1,LOGAD-CDCPARS(1)                                       27020000
         MH    1,=H'72'                                                 27090000
         A     1,=A(APLSDCBS)                                           27160000
         ST    1,IOBDCB                                                 27230000
         MVC   IOBFLAG1(2),=X'C200'                                     27300000
         MVC   IOBSTART(3),=AL3(RD1ST)                                  27370000
         MVC   IOBERRCT(2),=H'0'                                        27440000
         L     1,RD1ST                                                  27510000
         MVC   IOBSKPT(7),0(1)                                          27580000
         XC    EVNTCB(4),EVNTCB                                         27650000
         EXCP  IOB                                                      27720000
         WAIT  ECB=ECB                                                  27790000
         DROP  3                                                        27860000
         MVI   REJECT-M(11),0      BUFFER NOW TRULY OCCUPIED            28000000
         ICALL DRDZ                                                     28070000
         LM    2,6,DWRT+4                                               28140000
         IRETURN                                                        28210000
         SPACE 2                                                        28280000
         ENTRY DRDREST                                                  28350000
DRDREST  PROLOG                                                         28420000
         STM   2,6,DWRT+4          MUST BE CALLED AFTER DRDR1, EXCEPT   28490000
*                                  FOR INCDUMP WHICH MAY READ REC 1 AND 28560000
*                                  IGNORE IT.                           28630000
         MVI   DOP+1,X'06'         TELL CDCOMP TO READ                  28700000
         LA    15,WLEN                                                  28770000
         USING WLEN,15                                             5989 28840000
         BAL   6,CDCOMP                                            5989 28910000
         CLI   REJECT-M(11),0      IF REJECTED BY CDCOMP, DON'T ATTEMPT 28980000
         BNZ   DRD2                TO READ.                             29050000
         MVI   DRDZFG,0            SET FIRST-TIME SWITCH FOR END OF REA 29120000
         CLI   ONETRK,0            IF WORKSPACE FITS ON ONE TRACK,      29190000
         BE    DRD2                SKIP FURTHER DISK READING.           29260000
         L     1,CDCBASE  DISK POINTER TO DESIRED FILE                  29750000
         LA    3,IOB                                                    29820000
         USING IOBECB,3                                                 29890000
         LH    1,LOGAD-CDCPARS(1)  LOAD INDEX OF DCB                    29960000
         MH    1,=H'72'  MULTIPLY BY LENGTH OF DCB                      30030000
         A     1,=A(APLSDCBS)  ADD BASE OF DCBS                         30100000
         ST    1,IOBDCB  STORE IN OIB DCB ADDRESS                       30170000
         MVC   IOBFLAG1(2),=X'C200'                                     30240000
         MVC   IOBSTART(3),=AL3(CCWAR+32)                               30310000
         MVC   IOBERRCT(2),=H'0'   ZERO ERROR COUNT                     30380000
         L     1,CCWAD                                                  30450000
         DROP  15                                                  5989 30520000
         L     1,32(1)        1ST HALF OF SECOND SEEK IN CHAIN          30590000
         MVC   IOBSKPT(7),0(1)     MV SEEK ADR TO IOB                   30660000
         XC    EVNTCB(4),EVNTCB    ZERO OUT EVENT CNTRL BLK             30730000
         DROP  3                                                        30800000
         EXCP IOB                                                       30870000
DRD2     LM    2,6,DWRT+4                                               31010000
         IRETURN                                                        31080000
*                                                                       31150000
*                                                                       31220000
DRDZ     PROLOG EDRS,EDRSZ                                              31290000
         ENTRY DRDZ                                                     31360000
         STM   0,8,EDRS            SAVE CALLER'S REGISTERS              31430000
         CLI   ONETRK,0       WAS THIS A ONETRAK WS?               5989 31500000
         BE    ENDDR1         YES, ALL DONE                        5989 31570000
         WAIT  ECB=ECB                                                  32480000
DRDZC    CLI   ECB,X'7F'                                                32550000
         BNE   ENDDR2                                                   32620000
         CLC   IOBSTAT-IOBECB+IOB(2),=X'0C00'                           32690000
         BE    ENDDR1         ALL DONE                             5989 32760000
ENDDR2   MVC   DRDMST(2),IOBSTAT-IOBECB+IOB                             32830000
         L     1,CDCBXLE+8                                              32970000
         MVC   DRDMLU(44),DSLAB-CDCPARS(1)                              33040000
         L     1,CDCAD             AND WSNAME                           33110000
         MVC   DRDMWF(16),WFLLIB-M(1)                                   33180000
         ICALL OUTWRTL                                                  33250000
         DC    AL4(DRDMSG)                                              33320000
         MVI   REJECT-M(1),3       DISMISS THIS WS                 C059 33390000
         B     ENDDR3              BYPASS VALIDITY CHECKING             33460000
         SPACE 3                                                   5989 33530000
ENDDR1   TS    DRDZFG              WORKSPACE VALIDITY CHECK.            33600000
         BNZ   ENDDR3              CHECK ONLY AFTER DRDREST CALL        33670000
         LA    15,WLEN        ADDRESSIBILITY                       5989 33740000
         BAL   8,RELOC        DO ANY NECESSARY INCORE MOVES        5989 33810000
         L     8,CCPAR1                                                 33880000
         USING M,8                 BYPASS ANY WORKSPACE WITH BAD        33950000
*                                  POINTERS, SYMBOL TABLE, OR M-ENTRIES 34020000
         CLI   WFLNAME,C'A'        IGNORE DIRECTORIES                   34090000
         BE    ENDDR3                                                   34160000
         L     1,=A(WSLEN)                                              34230000
         CLC   0(4,1),QR13STK      QR13STK IS FAIRLY IMPORTANT PTR      34300000
         BNH   VWFAIL                                                   34370000
         CLC   QSYMBOT(4),PARREL                                        34440000
         BNH   VWFAIL                                                   34510000
         CLC   PARREL(4),MX                                             34580000
         BNH   VWFAIL                                                   34650000
         TM    QR13STK+3,3                                              34720000
         BNZ   VWFAIL                                                   34790000
         TM    QSYMBOT+3,3                                              34860000
         BNZ   VWFAIL                                                   34930000
         TM    PARREL+3,3                                               35000000
         BNZ   VWFAIL                                                   35070000
         TM    MX+3,3                                                   35140000
         BNZ   VWFAIL                                                   35210000
         LM    1,2,QR13STK ,QSYMBOT                                     35280000
         CLR   1,2                 BOTTOM LOWER THAN TOP OF S.T.        35350000
         BNH   VWFAIL                                                   35420000
         LA    0,8                                                      35490000
         AR    1,8                 ABS S.T. POINTERS                    35560000
         AR    2,8                                                      35630000
         BCTR  1,0                                                      35700000
VW5      OC    0(8,2),0(2)         NO ENTRY                             35770000
         BZ    VW1A                                                     35840000
         TM    0(2),X'80'          KEYWORD                              35910000
         BO    VW2                 NO BETS                              35980000
         L     3,0(2)                                                   36050000
         C     3,VWUNV             UNDEFINED VARIABLE                   36120000
         BE    VW2                                                      36190000
         TM    3(2),3                                                   36260000
         BNZ   VWFAIL                                                   36330000
         LA    3,0(3)                                                   36400000
         CL    3,MX                POINTS BELOW MX                      36470000
         BNL   VWFAIL                                                   36540000
         CL    3,=A(FREE-M)                                             36610000
         BL    VWFAIL                                                   36680000
         AR    3,8                                                      36750000
         TM    0(3),X'80'          NOT GARBAGE                          36820000
         BO    VWFAIL                                                   36890000
         L     4,0(3)                                                   36960000
         LA    4,M(4)              POINTERS REFLECT                     37030000
         CR    2,4                                                      37100000
         BNE   VWFAIL                                                   37170000
         CLI   0(2),TERMSYM        VALID SYMBOL CLASS                   37240000
         BNL   VWFAIL                                                   37310000
         CLI   0(2),DFN                                                 37380000
         BL    VW3                 NOT A LIST                           37450000
         TM    0(3),MLSTBIT                                             37520000
         BZ    VWFAIL                                                   37590000
         B     VW2                                                      37660000
VW3      TM    0(3),MLSTBIT        MUST NOT BE LIST                     37730000
         BO    VWFAIL                                                   37800000
VW2      L     3,4(2)              LOOK AT PRINTNAME                    37870000
         LTR   3,3                                                      37940000
         BZ    VWFAIL              MUST EXIST                           38010000
         LA    5,4(2)                                                   38080000
         CLI   4(2),3                                                   38150000
         BNH   VW1                 SHORT PNAME                          38220000
         TM    7(2),3                                                   38290000
         BNZ   VWFAIL              NOT MULT OF 4                        38360000
         LA    3,0(3)                                                   38430000
         CL    3,MX                MUST POINT INTO M-ENTRIES            38500000
         BNL   VWFAIL                                                   38570000
         CL    3,=A(FREE-M)                                             38640000
         BL    VWFAIL                                                   38710000
         AR    3,8                                                      38780000
         TM    0(3),X'80'          NOT GARBAGE                          38850000
         BO    VWFAIL                                                   38920000
         L     4,0(3)                                                   38990000
         LA    4,M(4)                                                   39060000
         S     4,=F'4'                                                  39130000
         CR    2,4                 POINTERS MUST REFLECT                39200000
         BNE   VWFAIL                                                   39270000
         CLC   4(1,2),8(3)         COUNTS SHOULD MATCH                  39340000
         BNE   VWFAIL                                                   39410000
         CLI   8(3),77                                                  39480000
         BH    VWFAIL                                                   39550000
         SR    4,4                                                      39620000
         IC    4,8(3)                                                   39690000
         LA    4,MPNAME-M+4(4)     COMPARE CHAR COUNT TO BYTE COUNT     39760000
         N     4,=F'-4'                                                 39830000
         C     4,MCOUNT-M(3)                                            39900000
         BNE   VWFAIL                                                   39970000
         LA    5,8(3)                                                   40040000
VW1      SR    6,6                 CHECK LEGALITY OF PRINTNAME ZSYMBOLS 40110000
         IC    6,0(5)                                                   40180000
         LA    7,IDZT                                                   40250000
         LA    5,1(5)                                                   40320000
         CLI   0(5),Z0             FIRST CHARACTER MUST                 40390000
         BNL   VWFAIL                  BE ALPHABETIC                    40460000
         BAL   LKR,VWZC                                                 40530000
VW1A     BXLE  2,0,VW5             END OF SYMBOL TABLE LOOP             40600000
         LA    2,FREE                                                   40670000
         L     1,MX                LOOK AT M-ENTRIES                    40740000
         AR    1,8                                                      40810000
         CLR   1,2                                                      40880000
         BL    VWFAIL                                                   40950000
         BE    ENDDR3              EMPTY WORKSPACE                      41020000
VW10     TM    0(2),X'80'          GARBAGE IS IMPOSSIBLE                41090000
         BO    VWFAIL                                                   41160000
         TM    3(2),3                                                   41230000
         BNZ   VWFAIL              MHEAD NOT MULT OF 4                  41300000
         TM    7(2),3                                                   41370000
         BNZ   VWFAIL              COUNT NOT MULT OF 4                  41440000
         L     3,4(2)                                                   41510000
         ALR   3,2                                                      41580000
         CLR   3,1                 COUNT LESS THAN MX                   41650000
         BH    VWFAIL                                                   41720000
         L     3,0(2)                                                   41790000
         LA    3,0(3)                                                   41860000
         C     3,QR13STK           POINTS TO SYMBOL TABLE,              41930000
         BNL   VWFAIL                                                   42000000
         C     3,PARREL            STACK,                               42070000
         BNL   VW15                                                     42140000
         C     3,MX                OR M-ENTRY                           42210000
         BNL   VWFAIL                                                   42280000
         C     3,=A(FREE-M)                                             42350000
         BL    VWFAIL                                                   42420000
VW15     LR    5,3                 COPY OF REL S.T. POINTER             42490000
         AR    3,8                                                      42560000
         L     4,0(3)                                                   42630000
         LA    4,M(4)                                                   42700000
         CR    2,4                 POINTERS REFLECT                     42770000
         BNE   VWFAIL                                                   42840000
         S     5,QSYMBOT           IF NOT A MULT OF 8 FROM SYMBOT,      42910000
         BM    VW16                AND INSIDE THE SYMBOL TABLE,         42980000
         EX    5,VWTM                                                   43050000
         BNZ   VW6                 IT'S A LONG PNAME, ALREADY CHECKED.  43120000
VW16     TM    0(2),MLSTBIT        CHECK VARB, TEMP VALIDITY            43190000
         BO    VW11                LIST VALIDITY                        43260000
         CLI   0(3),VARB                                                43330000
         BE    VW7                                                      43400000
         CLI   0(3),CONST                                               43470000
         BE    VW7                 TEMP                                 43540000
         CLI   0(3),CDST                                                43610000
         BNE   VW6                 MYSTERY, MIGHT BE VALID              43680000
         LH    7,MCSCNT-M(2)       CODESTRING                           43750000
         LA    7,MCSORG-M+3(7)     JUST CHECK SYL COUNT                 43820000
         N     7,=F'-4'                                                 43890000
         C     7,MCOUNT-M(2)       MUST BE LEQ COUNT                    43960000
         BNE   VWFAIL                                                   44030000
         CLC  MCSCNT-M(7,2),=AL1(0,5,1+2*ZREM,ZILG,0,1,1+2*ZCCONST) A04 44170000
         BNE   *+8                                                  A04 44240000
         MVI   MCSORG+1-M(2),ZBLANK     REPLACE ZILG WITH BLANK     A04 44310000
         LA    4,MCSORG-M(2)       R2 PTS TO START OF M ENTRY           44380000
         AH    4,MCSCNT-M(2)       R4 PTS TO RIGHT END OF CODESTRING,   44450000
         BCTR  4,0                 AND IS PTR REG ALONG STRING(R TO L)  44520000
MORE     TM    0(4),X'01'          SHORT OR LONG SYLLABLE?              44590000
         BZ    LSYLL               LONG                                 44660000
*                                                                       44730000
*                                  SHORT SYLLABLE                       44800000
*                                                                       44870000
         CLI   0(4),1+2*ZFILL17                                         44940000
         BL    VW4                                                      45010000
         CLI   0(4),1+2*ZTDELTA                                         45080000
         BE    OK                                                       45150000
         CLI   0(4),1+2*ZSDELTA                                         45220000
         BNE   VWFAIL                                                   45290000
VW4      CLI   0(4),1+2*ZLBR                                            45360000
         BNL   OK                  *                                    45430000
         SR    6,6                                                      45500000
         SR    7,7                 SET UP BRANCH TO PROPER              45570000
         IC    7,0(4)                  ROUTINE TO CHECK FOR             45640000
         SRA   7,1                         CONSTANTS.                   45710000
         IC    6,TBL(7)                                                 45780000
         B     X(6)                                                     45850000
X        EQU   *                                                        45920000
XEOS     LA    7,MCSORG-M(2)       WE HAVE EOS...                       45990000
         CR    4,7                 ARE WE AT THE END OF THE STRING.     46060000
         BNH   VW6                                                      46130000
BAD      B     VWFAIL                                                   46200000
CON      IC    7,STBL-ZBCONST(7)   R7 HAS SHIFT VALUE FOR CONSTANT      46270000
         SH    4,=H'2'             MOVE PTR TO ELEMENT CNT              46340000
         MVC   TEMPH(2),0(4)       HALFWD BDRY                          46410000
         LH    6,TEMPH                                                  46480000
         SLA   6,0(7)              COMPUTE BYTE LENGTH OF CONST         46550000
         BM    VWFAIL              NEGATIVE COUNT                       46620000
         LA    6,7(6)              *                                    46690000
         SRA   6,3                 *                                    46760000
         CH    6,MCSCNT-M(2)       IS IT G.T. CODESTRING LENGTH.        46830000
         BH    VWFAIL              YES, NO GOOD                         46900000
         STH   6,TEMPH                                                  46970000
         CLI   2(4),1+ZCCONST*2    IS THIS A CHAR CONSTANT              47040000
         BNE   BACK                NO                                   47110000
         LR    5,4                 YES, CHECK FOR LEGAL Z-SYMBOLS       47180000
         SR    5,6                 PT TO START OF FIELD                 47250000
         LA    7,GENZT             *                                    47320000
         BAL   LKR,VWZC            *                                    47390000
BACK     SH    4,TEMPH             MOVE PTR TO END OF CONSTANT          47460000
         LA    7,MCSORG-M(2)       END OF CON COINCIDES WITH            47530000
         CR    4,7                   END OF CODESTRING...INVALID        47600000
         BNH   VWFAIL                SINCE NO EOS OR REM                47670000
         B     OK                                                       47740000
*                                                                       47810000
*                                  LONG SYLLABLE                        47880000
*                                                                       47950000
LSYLL    BCTR  4,0                 PT TO START OF LONG SYLLABLE         48020000
         TM    0(4),X'80'          NEGATIVE VALUE                       48090000
         BO    LSYLL1              YES                                  48160000
         OC    0(2,4),0(4)         NO, IS IT ZERO.                      48230000
         BNZ   VWFAIL              NO, BAD SYLLABLE                     48300000
LSYLL1   MVC   TEMPH(2),0(4)       HALFWD BDRY                          48370000
         LH    6,TEMPH                                                  48440000
         SLA   6,2                 COMPUTE NEGATIVE ST DISP             48510000
         A     6,QR13STK           ADD DISP TO START OF ST              48580000
         C     6,QSYMBOT           DOES IT PT WITHIN ST?                48650000
         BL    VWFAIL                                                   48720000
OK       BCTR  4,0                                                      48790000
         LA    7,MCSORG-M(2)       ADDRESS OF CODESTRING END            48860000
         CR    4,7                 ARE WE THRU STRING?                  48930000
         BNL   MORE                NO                                   49000000
         LA    4,1(4)              PT TO LAST SYLL IN STRING            49070000
         CLI   0(4),1+2*ZEOS       CHECK FOR EOS OR LEOS                49140000
         BE    VW6                                                      49210000
         CLI   0(4),1+2*ZLEOS      *                                    49280000
         BE    VW6                                                      49350000
         CLI   0(4),1+2*ZREM                                            49420000
         BE    VW6                                                      49490000
         B     VWFAIL                                                   49560000
VW7      LA    7,1                 CHECK XRHO AND TYPE VS COUNT         49630000
         TM    MRANK-M+1(2),3      MUST BE MULT OF 4                    49700000
         BNZ   VWFAIL                                                   49770000
         LH    3,MRANK-M(2)                                             49840000
         CL    3,=F'256'                                                49910000
         BH    VWFAIL              UNREASONABLE RANK                    49980000
         LA    5,MRHO-M(2,3)       DATA ADDR FOR CHAR TYPE CHECK        50050000
         LTR   3,3                                                      50120000
         BZ    VW8                 SCALAR                               50190000
VW9      M     6,MRHO-M-4(2,3)                                          50260000
         LTR   6,6                                                      50330000
         BNZ   VWFAIL              UNREASONABLE XRHO                    50400000
         S     3,=F'4'                                                  50470000
         BP    VW9                                                      50540000
VW8      IC    3,MTYPE-M(2)                                             50610000
         BCTR  3,0                                                      50680000
         CL    3,=F'4'                                                  50750000
         BNL   VWFAIL              UNREASONABLE TYPE                    50820000
         IC    3,VWTS(3)                                                50890000
         CL    7,=A(X'FFFFFF')     REASONABLE XRHO                      50960000
         BH    VWFAIL                                                   51030000
         LR    6,7                                                      51100000
         SLL   7,0(3)                                                   51170000
         AL    7,=F'31'            ROUND TO WORD BDY                    51240000
         SRL   7,5                                                      51310000
         AH    7,MRANK-M(2)                                             51380000
         LA    7,MRHO-M(7)         SHOULD EQUAL COUNT                   51450000
         C     7,MCOUNT-M(2)                                            51520000
         BH    VWFAIL              TAKE THAT, BH0                       51590000
         CLI   MTYPE-M(2),4        ON CHARACTER TYPE,                   51660000
         BNE   VW6                                                      51730000
         LA    7,GENZT             CHECK FOR LEGAL ZSYMBOLS             51800000
         BAL   LKR,VWZC                                                 51870000
         B     VW6                                                      51940000
VW11     LH    3,MLSOS-M(2)                                             52010000
         LH    4,MLSCT-M(2)                                             52080000
         TM    MLSOS-M+1(2),3                                           52150000
         BNZ   VWFAIL              OFFSET MUST BE MULT OF 4             52220000
         LA    6,0(4,4)            CHECK LIST OFFSET AND ELEMENT COUNT  52290000
         AR    6,6                                                      52360000
         AR    6,3                 AGAINST BYTE COUNT                   52430000
         C     6,MCOUNT-M(2)                                            52500000
         BNE   VWFAIL                                                   52570000
         AR    3,2                 ABS ADDR OF FIRST LIST ELEMENT       52640000
         LTR   4,4                                                      52710000
         BZ    VW6                 EMPTY LIST                           52780000
VW14     CLI   0(3),0                                                   52850000
         BZ    VW13                NOT A POINTER                        52920000
         TM    3(3),3                                                   52990000
         BNZ   VWFAIL              NOT MULT OF 4                        53060000
         L     6,0(3)                                                   53130000
         LA    6,0(6)                                                   53200000
         TM    0(3),X'80'                                               53270000
         BO    VW12                INDIRECT                             53340000
         C     6,MX                MUST BE BELOW MX                     53410000
         BNL   VWFAIL                                                   53480000
         C     6,=A(FREE-M)                                             53550000
         BL    VWFAIL                                                   53620000
         L     7,M(6)                                                   53690000
         LA    7,M(7)                                                   53760000
         CR    7,3                 POINTERS REFLECT                     53830000
         BNE   VWFAIL                                                   53900000
         B     VW13                                                     53970000
VW12     C     6,PARREL            MUST POINT TO STACK                  54040000
         BL    VWFAIL                                                   54110000
         C     6,QR13STK           OR SYMBOL TABLE                      54180000
         BNL   VWFAIL                                                   54250000
VW13     LA    3,4(3)                                                   54320000
         BCT   4,VW14                                                   54390000
VW6      TM    MCOUNT-M(2),3       PROBABLY SUPERFLUOUS                 54460000
         BNZ   VWFAIL                                                   54530000
         L     7,MCOUNT-M(2)                                            54600000
         LTR   7,7                                                      54670000
         BNP   VWFAIL                                                   54740000
         AR    2,7                                                      54810000
         CR    1,2                                                      54880000
         BH    VW10                                                     54950000
         B     ENDDR3              ALL OK                               55020000
*                                  R7 POINTS TO TRT TABLE               55090000
*                                  R6 HAS FIELD LENGTH, R5 PTS TO FIELD 55160000
*                                  BOTH R5 AND R6 ARE DESTROYED.        55230000
*                                                                       55300000
VWZC     LTR   6,6                 Z-SYMBOL CHECKER                     55370000
         BCR   8,LKR               EMPTY                                55440000
         BCTR  6,0                                                      55510000
         STM   1,2,VWZCT                                                55580000
VWZC2    S     6,=F'256'                                                55650000
         BM    VWZC1                                                    55720000
         TRT   0(256,5),0(7)                                            55790000
         BNZ   VWFAIL                                                   55860000
         LA    5,256(5)                                                 55930000
         B     VWZC2                                                    56000000
VWZC1    EX    6,VWZCTR                                                 56070000
         BNZ   VWFAIL                                                   56140000
         LM    1,2,VWZCT                                                56210000
         BR    LKR                                                      56280000
VWZCTR   TRT   0(0,5),0(7)                                              56350000
VWTM     TM    =X'04',0                                                 56420000
VWFAIL   MVC   EDRSREG(16*4),0(8)                                   A04 56490000
         STM   0,15,0(8)                                            A04 56560000
         LA    3,=XL1'FF'          NO SNAPID FOR 'WS DAMAGED' MSG       58100000
         L     1,=A(UTFLAGS)       ADDR OF OPTION FLAGS                 58170000
         TM    0(1),UTWSDMP        WSDUMP OPTION SPECIFIED ?            58240000
         BZ    NOWSDMP             BRANCH IF NO                         58310000
         OC    WFLPASS,WFLPASS     IS WS PASSWORD PROTECTED ?           58380000
         BNZ   NOWSDMP             NO WSDUMP ALLOWED IF PASS PROT       58450000
         SR    0,0                 CLEAR GARBAGE BETWEEN                58520000
         L     1,MX                 MX AND SVI.                         58590000
         LA    2,4                                                      58660000
         L     3,SVI                                                    58730000
         ST    0,M(1)                                                   58800000
         BXLE  1,2,*-4                                                  58870000
         L     2,WLEN              PICK UP WS LENGTH                    58940000
         AR    2,8                 CALCULATE END OF WS                  59010000
         LH    3,SNAPID            CURRENT SNAP ID                      59080000
         L     0,=A(WSDMPDCB)      ADDR OF WSDUMP DCB FOR SNAP          59150000
         PRINT GEN                                                      59220000
         SNAP  ID=(3),DCB=(0),STORAGE=((8),(2))                         59290000
         STC   3,SNAPWRK1+8        STORE SNAPID IN MSG LINE WORKAR      59360000
         LA    3,1(3)              BUMP SNAPID                          59430000
         C     3,=F'256'           IF GREATER THAN 255,                 59500000
         BL    *+6                  RESET TO ZERO.                      59570000
         SR    3,3                                                      59640000
         STH   3,SNAPID                                                 59710000
         LA    3,SNAPWRK1          SNAPID FOR DWSLOG                    59780000
NOWSDMP  EQU   *                                                        59850000
         LA    0,WFLDATE                                                59920000
         LA    1,WFLLIB                                                 59990000
         LA    2,=CL9'IMPEACHED'   ACTION TAKEN                         60060000
         ICALL DWSLOG                                                   60130000
ENDDR4   MVC   0(16*4,8),EDRSREG   RESTORE WS REGISTERS             A04 60270000
         DROP  8                                                        60340000
ENDDR3   LM    0,8,EDRS                                                 60410000
         TS    ONETRK     SET FLAG SO THAT CALLS TO DRDZ IN RANDOM 5989 60480000
*              SEQUENCE DO THE PROPER ERROR CHECKING ON THE IOB    5989 60550000
         IRETURN                                                        60620000
VWUNV    DC    0F'0',AL1(VARB,0,0,0)                                    60690000
VWTS     DC    FL1'0,5,6,3'                                             60760000
DRDZFG   DC    X'FF'               FIRST-TIME FLAG FOR DRDZ             60830000
DRDMSG   DC    C'WORKSPACE'                                             60900000
         DC    X'11'                                                    60970000
DRDMWF   DC    XL16'00'            WS NO, NAME                          61040000
         DC    C' DISK READ ERROR. STATUS=',X'02'                       61110000
DRDMST   DC    X'0000',C' '                                             61180000
DRDMLU   DC    CL44' ',X'FF'                                            61250000
DRDZT    DS    F                                                        61320000
EDRS     DSECT                                                          61390000
         DS    9F                                                       61460000
VWZCT    DS    2F                                                       61530000
EDRSREG  DS    16F                 SAVES WS REGISTERS               A04 61600000
EDRSZ    EQU   *                                                        61670000
DISKSECT CSECT                                                          61740000
         TITLE 'DISK WRITE ROUTINE'                                     61810000
*                                                                       61880000
*                                                                       61950000
*        WRITE WORKSPACE DESIGNATED BY R11 TO DISK CCHH IN R1      DASD 62020000
*        R2 IS FILE NUMBER                                              62090000
*                                                                       62160000
DWR      PROLOG                                                         62230000
         ENTRY DWR                                                      62300000
         STM   1,6,DWRT                                                 62370000
         L     1,=A(WSLEN)                                              62440000
         L     1,0(1)                                                   62510000
         ST    1,WLEN                                                   62580000
         MVI   DOP+1,X'05'                                              62650000
         A     2,ADPAR                                                  62720000
         ST    2,CDCBASE                                                62790000
DWR1     EQU   *                                                        62860000
         ICALL DWRZ                                                     63210000
         MVC   PHYCYL,DWRT         SET UP ARGUMENTS FOR CDCOMP     DASD 63280000
         MVI   CCFIRST,0           RESET FIRST WRITE PASS SWITCH   DASD 63420000
         ST    11,DWRLAST                                               63560000
         MVC   CDCAD+1(3),DWRLAST+1                                     63630000
         LA    15,WLEN                                                  64120000
         BAL   6,CDCOMP-WLEN(15)                                        64190000
         MVI   CDOP,0         RESET ALTERNATE DIRECTORY SWITCH     5989 64260000
         L     1,CDCBASE  DISK POINTER TO DESIRED FILE                  64680000
         LA    3,IOB                                                    64750000
         USING IOBECB,3                                                 64820000
         LH    1,LOGAD-CDCPARS(1)  LOAD INDEX OF DCB                    64890000
         MH    1,=H'72'  MULTIPLY BY LENGTH OF DCB                      64960000
         A     1,=A(APLSDCBS)  ADD BASE OF DCBS                         65030000
         ST    1,IOBDCB  STORE IN OIB DCB ADDRESS                       65100000
         MVC   IOBFLAG1(2),=X'C200'                                     65170000
         MVC   IOBSTART(3),=AL3(CCWAR)                                  65240000
         MVC   IOBERRCT(2),=H'0'   ZERO ERROR COUNT                     65310000
         L     1,CCWAD                                                  65380000
         L     1,0(1)     LOAD 1ST HALF OF SEEK ADDRESS                 65450000
         MVC   IOBSKPT(7),0(1)     MV SEEK ADR TO IOB                   65520000
         XC    EVNTCB(4),EVNTCB    ZERO OUT EVENT CNTRL BLK             65590000
         DROP  3                                                        65660000
         EXCP  IOB                                                      65730000
         L     2,=A(UTFLAGS)       LISTING OF ALL WS LABELS WRITTEN     65870000
         TM    0(2),UTWSLST        MAY HAVE BEEN REQUESTED              65940000
         BZ    DWR2                                                     66010000
         CLI   WFLNAME-M(MR),C'A'  DON'T LIST DIRECTORIES -- IT GETS    66080000
         BE    DWR2                TEDIOUS                              66150000
         MVC   DWFMID(16),WFLLIB-M(MR) MOVE IN WSID                     66220000
         MVC   DWFMDT(12),WFLDATE-M(MR)  LIKEWISE TIME STAMP            66290000
         ICALL OUTWRT                                                   66360000
         DC    AL4(DWFMSG)                                              66430000
DWR2     LM    2,6,DWRT+4                                               66500000
         IRETURN                                                        66570000
*                                                                       66640000
*                                                                       66710000
DWFMSG   DC    CL7'       '        SPACES TO BE CONSISTENT W/ MTSECT    66780000
         DC    X'13'                                                    66850000
DWFMDT   DC    XL12'00'            DATE, TIME                           66920000
         DC    X'11'                                                    66990000
DWFMID   DC    XL16'00'            LIB NO, WSNAME                       67060000
         DC    X'FF'                                                    67130000
*                                                                       67200000
         SPACE                                                          67270000
DWRZ     PROLOG                                                         67340000
         ENTRY DWRZ                                                     67410000
         ST    1,DWRZT                                                  67480000
         WAIT  ECB=ECB                                                  68250000
         LA    1,IOB                                                    68320000
         USING IOBECB,1                                                 68390000
         CLI   ECB,X'7F'                                                68460000
         BNE   DWRZ1                                                    68530000
         CLC   IOBSTAT(2),=X'0C00' CHECK FOR NORMAL END                 68600000
         BE    DWRZ2                                                    68670000
DWRZ1    MVC   DWRMST(2),IOBSTAT                                        68740000
         DROP  1                                                        68810000
         L     1,CDCBXLE+8                                              68950000
         MVC   DWRMLU(44),DSLAB-CDCPARS(1)                              69020000
         L     1,DWRLAST                                                69090000
         MVC   DWRMWF(16),WFLLIB-M(1)  FILE LABEL OF UNFORTUNATE WS     69160000
         ICALL OUTWRTL                                                  69230000
         DC    AL4(DWRMSG)                                              69300000
DWRZ2    L     1,DWRZT                                                  69370000
         IRETURN                                                        69440000
         SPACE                                                          69510000
DWRMSG   DC    C'WORKSPACE'                                             69580000
         DC    X'11'                                                    69650000
DWRMWF   DC    XL16'00'                                                 69720000
         DC    C' DISK WRITE ERROR. STATUS=',X'02'                      69790000
DWRMST   DC    X'0000',C' '                                             69860000
DWRMLU   DC    CL44' ',X'FF'                                            69930000
DWRZT    DS    F                                                        70000000
DWRLAST  DS    F                                                        70070000
DWRT     DS    6F                  USED ALSO BY DISK READ               70140000
         TITLE 'DIRECTORY READ AND WRITE ROUTINES'                      70210000
*                                                                       70280000
*                                                                       70350000
*        WRITE TWO COPIES OF A DIRECTORY TO THE CORRECT DISK LOCATIONS. 70420000
*        R10 IS CORE LOCATION, R1 IS DIRECTORY NUMBER                   70490000
*                                                                       70560000
DIRWRT   NOPR  15                  ********** PROGRAM MODIFIED BY MAIN  70630000
*                                  ********** TO INHIBIT DIRWRT FOR     70700000
*                                  ********** TESTBILL COMMAND ******** 70770000
         PROLOG                                                         70840000
         ENTRY DIRWRT                                                   70910000
         ST    11,DIRT                                                  70980000
         LR    11,10                                                    71050000
         STM   0,3,DIRT+4                                               71120000
         USING M,10                                                     71190000
*        UPDATE FREEDSK TABLE IN THIS DIRECTORY                         71260000
UPDFR1   LM    0,2,CDCBXLE                                              71330000
         LA    3,FREEDSK                                                71400000
UPDFR2   MVC   0(4,3),CFREDSK-CDCPARS(2)                                71470000
         LA    3,4(3)                                                   71540000
         BXLE  2,0,UPDFR2          NEXT LIBRARY                         71610000
         L     1,DIRT+8            RESTORE R1                           71680000
         SLL   1,3                                                      71750000
         LR    2,1                                                      71820000
         L     1,=A(DIRTAB)                                             71890000
         L     1,0(1,2)                                                 71960000
         SR    2,2                                                      72030000
         ICALL DWR                 WRITE IT.                            72100000
         ICALL DWRZ                                                     72170000
         MVI   CDOP,8         SET "ALTERNATE DIRECTORY" SWITCH,SO  5989 72240000
*              THAT DIRECTORY DATA IS NOT MOVED A SECOND TIME.     5989 72310000
         L     2,DIRT+8                                                 72380000
         SLL   2,3                                                 5989 72450000
         L     1,=A(DIRTAB)                                             72520000
         L     1,4(1,2)                                                 72590000
         SR    2,2                                                      72660000
         ICALL DWR                                                      72730000
         ICALL DWRZ                                                     72800000
*        THE ABOVE SHUFFLE WITH CDOP PREVENTED DOING THE INCORE    5989 72870000
*        MOVE A SECOND TIME, BUT THE DATA HAS BEEN MOVED           5989 72940000
*        (SEE CDCOMP FOR DESCRIPTION).                             5989 73010000
*        IF THE INCORE MOVE WAS DESTRUCTIVE, THEN WE HAVE TO       5989 73080000
*        RESTORE THE DATA IN CORE.                                 5989 73150000
         LA    15,WLEN        ESTABLISH ADDRESSABILITY             5989 73220000
         USING WLEN,15                                             5989 73290000
         CLI   ONETRK,INCORMV WAS THE DATA MOVED IN CORE ?         5989 73360000
         BNE   UPDFR3         NO, WE DON'T HAVE TO MOVE IT BACK    5989 73430000
         L     1,CCPAR1       ADDRESS OF WORKSPACE                 5989 73500000
         USING M,1                                                 5989 73570000
         LM    2,3,MX         GET MX AND SVI                       5989 73640000
         LA    2,7(,2)        ROUND MX TO A DOUBLE-WORD BOUNDARY   5989 73710000
         N     2,=F'-8'                                            5989 73780000
         N     3,=F'-8'       ROUND SVI TO A DOUBLE-WORD BOUNDARY  5989 73850000
         SR    3,2            GET THE LENGTH OF THE GARBAGE AREA   5989 73920000
         LH    2,MVCLNGTH     GET THE LENGTH OF THE MOVE           5989 73990000
         LPR   2,2            MAKE IT POSITIVE                     5989 74060000
         CR    3,2            WAS THE MOVE DESTRUCTIVE ?           5989 74130000
         BNL   UPDFR3         NO, MOVE BACK NOT NECESSARY          5989 74200000
*                                                                  5989 74270000
*        FIX UP THE DAMAGED WS                                     5989 74340000
*                                                                  5989 74410000
         BAL   0,MVCREV       GO MOVE THE DATA BACK                5989 74480000
         DROP  1,15                                                5989 74550000
UPDFR3   EQU   *                                                   5989 74620000
         L     11,DIRT                                                  74690000
         LM    0,3,DIRT+4                                               74760000
         IRETURN                                                        74830000
         DROP  10                                                       74900000
         EJECT                                                          74970000
*                                                                       75040000
*        READ DIRECTORY SPECIFIED BY R1 INTO CORE SPECIFIED BY R10.     75110000
DIRREAD  PROLOG                                                         75180000
         ENTRY DIRREAD                                                  75250000
         STM   1,2,DIRT                                                 75320000
         ST    11,DIRT+8                                                75390000
         LR    11,10                                                    75460000
         SLL   1,3                                                      75530000
         L     2,=A(DIRTAB)                                             75600000
         AR    1,2                 ADDR OF CCHH, PRIMARY DIRECTORY      75670000
         ST    1,DIRT2                                                  75740000
         MVI   DIRRALT,0           ATTEMPTING TO READ PRIMARY           75810000
         L     1,0(1)                                                   75880000
DIRR2    SR    2,2                                                      75950000
         ICALL DRD                                                      76020000
         ICALL DRDZ                                                     76370000
         CLI   REJECT-M(11),3      CHECK FOR HARD ERROR            C059 76440000
         BE    DIRRX               DIR IS UNREADABLE               C059 76510000
         SR    2,2                 ERR CODE IF NOT A DIR           C059 76580000
         CLC   WFLNAME-M(12,11),=C'APLDIRECTORY'                        76650000
         BNE   DIRERR              NOT A DIRECTORY                 C059 76720000
         LA    2,4                 ERR CODE IF DIR FORMAT WRONG    C059 76790000
         CLC   VVMM-M(4,11),=C'V1M1' DIR WRITTEN BY V1M1 UTIL?     C059 76860000
         BNE   DIRERR              NO.  INCOMPATIBLE DIR FORMATS   C059 76930000
         LA    2,8                 ERR CODE IF DIRS OR WSLEN WRONG C059 77000000
         L     LKR,=A(KMANHASH)                                    C059 77070000
         L     LKR,0(LKR)          NO. DIRS FROM CONFIG            C059 77140000
         LA    0,1000                                              C059 77210000
         A     0,QR13STK-M(11)     ACTUAL WSLEN FROM LIB           C059 77280000
         L     1,=A(WSLEN)                                         C059 77350000
         C     0,0(1)              ACTUAL WSLEN VS. CONFIG WSLEN   C059 77420000
         BNE   DIRERR              MISMATCH.  LET'S QUIT           C059 77490000
         C     LKR,NUMDIRS-M(11)   CONFIG DIRS VS. ACTUAL DIRS     C059 77560000
         BNE   DIRERR              MISMATCH.  LET'S QUIT           C059 77630000
         CLI   REJECT-M(11),0      JUST IN CASE MX & SVI BAD       C059 77700000
         BNE   DIRRX               SCRAMBLED INNARDS.  REJECT      C059 77770000
         LM    1,2,DIRT                                                 77840000
         L     11,DIRT+8                                                77910000
         IRETURN                                                        77980000
DIRRX    XI    DIRRALT,1           HAVE WE TRIED ALTERNATE YET --       78050000
         BZ    DIRR3               YES                                  78120000
         ICALL OUTWRTL             NO.  LOG PRIMARY FAILURE AND TRY ALT 78190000
         DC    AL4(DIRRMSG)                                             78260000
         L     1,DIRT2                                                  78330000
         L     1,4(1)              ALTERNATE DIRECTORY CCHH             78400000
         B     DIRR2                                                    78470000
DIRR3    ICALL OUTWRTL                                                  78540000
         DC    AL4(DIRRMSGA)                                            78610000
         CANCEL                                                         78680000
DIRRMSGA DC    C'ALTERNATE '                                            78750000
DIRRMSG  DC    C'DIRECTORY READ FAILURE '                               78820000
         DC    X'FF'                                                    78890000
DIRT     DS    3F                                                       78960000
DIRT2    DS    2F                                                       79030000
DIRRALT  DS    XL1                                                      79100000
         TITLE 'LITERALS AND USEFUL CONSTANTS'                          79170000
WLEN     DC    A(0)                                                     79240000
MANHASH  DC    F'0'                                                     79310000
DIRIN    DC    H'0'                                                     79380000
CDCBASE  DC    A(LIBPARS)                                               79450000
CDCBXLE  DC    A(CDCL,LIBPZ,LIBPARS)                                    79520000
ADPAR    EQU   CDCBXLE+8                                                79590000
TOHEX    EQU   *-C'0'                                                   79660000
         DC    C'0123456789ABCDEF'                                      79730000
         SPACE 3                                                   5989 79800000
         LTORG                                                     5989 79870000
         SPACE 3                                                   5989 79940000
DIRERR   DS    0H                                                  C059 80010000
         L     3,NUMDIRS-M(11)     ACTUAL NO. DIRS                 C059 80080000
         LR    4,LKR               NO. DIRS FROM CONFIG            C059 80150000
         LR    5,0                 WSLEN IN LIBRARY                C059 80220000
         L     1,=A(WSLEN)                                         C059 80290000
         L     6,0(1)              WSLEN FROM CONFIG               C059 80360000
         ICALL OUTWRTL             'INCOMPATIBLE APL LIB FORMATS'  C059 80430000
         DC    AL4(DIRRMSGB)       MUST FOLLOW ICALL               C059 80500000
         ABEND 1098,DUMP           BAD DIRECTORIES                 C059 80640000
DIRRMSGB DC    C'INCOMPATIBLE APL LIBRARY FORMAT'                  C059 81060000
         DC    X'FF'               MUST FOLLOW DIRRMSGB            C059 81130000
         DS    0H                                                       81200000
ZERO     DC    H'0'                                                     82390000
SNAPID   DC    H'0'                SNAP ID FOR WSDUMP                   82460000
         DS    0F                                                       82530000
IOB      DC    F'0'                INITIALIZED FOR LEADING WAIT         82600000
         DC    A(ECB)              COMPLETE                             82670000
         DC    4X'00'                                                   82740000
         DC    X'0C000000'                                              82810000
         DC    6F'0'                                                    82880000
ECB      DC    X'7F000000'                                              82950000
SNAPWRK1 DC    C'SNAPID='          FOR 'WS DAMAGED' MSG WITH WSDUMP     83020000
         DC    X'1200'             MUST BE AFTER SNAPWRK1               83090000
IDZT     DC    256X'11'                                                 83230000
         ORG   IDZT+ZA                                                  83300000
         DC    64X'00'             ALPHA, ALPHA, NUMERIC                83370000
         ORG                                                            83440000
GENZT    DC    256X'11'                                                 83510000
         ORG   GENZT+ZLBR                                               83580000
         DC    (ZFILL17-ZLBR)X'00'                                      83650000
         ORG   GENZT+ZA                                                 83720000
         DC    (ZEOB-ZA)X'00'                                           83790000
         ORG   GENZT+ZBS                                                83860000
         DC    (ZLENGTH-ZBS)X'00'                                       83930000
         ORG                                                            84000000
*                                  IN THE FOLLOWING TABLES,ASSUMPTIONS  84070000
*                                    HAVE BEEN MADE AS TO THE ORDER-    84140000
*                                    ING OF THE Z-SYMBOLS.              84210000
STBL     DC    AL1(0,5,6,3)        SHIFT VALUES FOR CONSTANTS CNTS      84280000
TBL      DC    AL1(BAD-X)                                               84350000
         DC    AL1(XEOS-X)                                              84420000
         DC    AL1(XEOS-X)                                              84490000
         DC    AL1(OK-X)                                                84560000
         DC    AL1(BAD-X)                                               84630000
         DC    AL1(BAD-X)                                               84700000
         DC    AL1(BAD-X)                                               84770000
         DC    AL1(OK-X)                                                84840000
         DC    AL1(OK-X)                                                84910000
         DC    AL1(OK-X)                                                84980000
         DC    AL1(CON-X)                                               85050000
         DC    AL1(CON-X)                                               85120000
         DC    AL1(CON-X)                                               85190000
         DC    AL1(CON-X)                                               85260000
TEMPH    DC    H'0'                                                     85330000
         EXTRN KMANHASH                                                 85400000
         EXTRN PARAMS                                                   85470000
         EXTRN CCREJ                                                    85540000
         EXTRN DISKFMT                                                  85610000
         EXTRN DIRTAB                                                   85680000
         EXTRN WSLEN                                                    85750000
         EXTRN LIBPARS                                                  85820000
         EXTRN LIBPZ                                                    85890000
         EXTRN OUTWRT                                                   85960000
         EXTRN OUTWRTL                                                  86030000
         EXTRN UTFLAGS                                                  86100000
         EXTRN WSLOC                                                    86170000
         ENTRY ADPAR                                                    86240000
         EXTRN APLSDCBS                                                 86800000
         EXTRN WSDMPDCB                                                 86870000
         IOBECBD                                                        86940000
         ENTRY CDCAD                                                    87080000
         ENTRY CDCBASE                                                  87150000
         ENTRY CDCBXLE                                                  87220000
UTWSLST  EQU   X'80'               UTFLAGS MASK - WSLIST                87290000
UTWSDMP  EQU   X'20'               UTFLAGS MASK - DUMP REJECTED WSS     87360000
REJECT   EQU   M                                                        87430000
         TITLE 'DISK CCW COMPUTATION'                                   87500000
*                                                                       87570000
         DROP  12                                                       87640000
         USING WLEN,15        SAME ADDRESSIBILITY AS CDCOMP        5989 87710000
RELOC    CLI   ONETRK,INCORMV                                      5989 87780000
         MVI   ONETRK,NOT1TRK                                      5989 87850000
         BCR   2,8                                                 5989 87920000
         L     1,CCPAR1                                            5989 87990000
         LR    0,8            RETURN ADDRESS FOR FAKE BAL          5989 88060000
         B     MVCREV         GO MOVE THE DATA BACK                5989 88130000
         SPACE 3                                                   5989 88200000
         USING WLEN,15                                             5989 88270000
         COPY  CDINF                                               DASD 88340000
CDCOMP   REMCDC ,                                                  DASD 88410000
         DROP  15                                                       88480000
*                                                                       88550000
         LTORG                                                          88620000
*                                                                       88690000
         COPY  CDCPARS                                                  88760000
         COPY  DIRSECT                                                  88830000
         END                                                            88900000
./  ADD    NAME=APLUDUMP
DUMP     TITLE 'APL UTILITY DUMP ROUTINES                     05/11/70' 00180000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00360000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00540000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00720000
*                                                                       01440000
         EXTRN CCREJ                                                    01620000
         EXTRN DIRREAD                                                  01800000
         EXTRN DIRWRT                                                   01980000
         EXTRN DRD                                                      02160000
         EXTRN DRDR1                                                    03060000
         EXTRN DRDREST                                                  03240000
         EXTRN DRDZ                                                     03420000
         EXTRN DSEEK                                                    03600000
         EXTRN DWSLOG                                                   03780000
         EXTRN KMANHASH                                                 03960000
         EXTRN LCYLOG                                                   04140000
         EXTRN LOC8MAN                                                  04320000
         EXTRN MTWCLOSE                                                 04500000
         EXTRN MTWOPEN                                                  04680000
         EXTRN MTWR                                                     04860000
         EXTRN MTWRZ                                                    05040000
         EXTRN OUTWRTL                                                  05220000
         EXTRN PARAMS                                                   05400000
         EXTRN SELCARD                                                  05580000
         EXTRN TRECLEN                                                  05760000
         EXTRN UTDATE                                                   05940000
         EXTRN UTFLAGS                                                  06120000
         EXTRN VTOZ                                                     06300000
         EXTRN WSLEN                                                    06480000
         EXTRN WSLOC                                                    06660000
         PRINT OFF                 COPY APLDEFN ZSYMBOLS                06840000
         COPY APLDEFN                                                   07020000
         COPY  ZSYMBOLS                                                 07200000
         TITLE 'APL UTILITY DUMP ROUTINE                      05/11/70' 07380000
         PRINT ON,NOGEN                                                 07560000
DUMPSECT CSECT                                                          07740000
*                                                                       07920000
*                                                                       08100000
*                                                                       08280000
DDUMP    PROLOG                                                         08460000
         ENTRY DDUMP                                                    08640000
         MVI   IDFLAG,0            NOT INCREMENTAL DUMP                 08820000
         MVI   IDNXPS,1            GUARANTEE NONZERO                    09000000
         B     DUMPCM                                                   09180000
*                                                                       09360000
*              INCREMENTAL DUMP                                         09540000
*                                                                       09720000
         ENTRY IDUMP                                                    09900000
IDUMP    PROLOG                                                         10080000
         MVI   IDFLAG,1            DOING AN INCREMENTAL DUMP            10260000
*                                                                       10440000
DUMPCM   BALR  12,0                REESTABLISH ADDRESSING               10620000
         USING *,12                                                     10800000
         L     1,=A(UTDATE)        LOCATE EBCDIC DATE                   10980000
         MVC   RTS(8),0(1)                                              11160000
         L     1,=A(VTOZ)          MAP TO ZSYMBOLS                      11340000
         TR    RTS(8),0(1)                                              11520000
         MVI   RTS+2,ZSLASH        VTOZ DOESN'T HOLD ZSLASH             11700000
         MVI   RTS+5,ZSLASH                                             11880000
         GETIME TU                                                      12060000
         ST    1,RTS+8                                                  12240000
         ICALL DISUB               SET UP DUMP AND SELDUMP PARAMETERS   12420000
         SR    2,2                                                      12600000
         ST    2,IWSCNT            INITIALIZE NO. OF INCDUMPED WSS      12780000
         LR    11,10                                                    12960000
*              FIRST WRITE ALL (MANHASH) DIRECTORIES TO TAPE            13140000
DDUMPDR  LR    1,2                                                      13320000
         ICALL DIRREAD                                                  13500000
         LTR   1,2                 ON DIRECTORY 0 ONLY,                 13680000
         BNZ   DD1                                                      13860000
         MVC   DIDTS-M(12,10),RTS  WRITE INCREMENTAL-DUMP TIMESTAMP     14040000
         CLI   IDFLAG,0                                                 14220000
         BNE   DD2                                                      14400000
         MVC   DFDTS-M(12,10),RTS  ALSO FULL-DUMP TIMESTAMP IF NOT INC- 14580000
DD2      MVC   RTS2(12),DFDTS-M(10) DUMP.                               14760000
DD1      ICALL MTWR                                                     14940000
         ICALL MTWRZ                                                    15120000
         LA    2,1(2)                                                   15300000
         C     2,HASHVAL                                                15480000
         BL    DDUMPDR                                                  15660000
         XC    WSTATS(12),WSTATS                                        15840000
         SR    1,1                 START DUMPING WITH DIRECTORY 0.      16020000
DDCS     STH   1,CURDIR                                                 16200000
         MVI   IDAFLG,0            1ST-TIME-ONLY FLAG FOR INCDUMP       16380000
         L     10,DIRWS                                                 16560000
*              PREPARE TO DUMP FROM NEXT DIRECTORY                      16740000
         ICALL DIRREAD                                                  16920000
         L     11,CURWS                                                 17100000
         BAL   15,TABTRAC                                               17280000
         B     DDB                                                      17460000
*                                                                       17640000
*              REENTRY FROM TABTRAC WITH ANOTHER PERSAVW TO PROCESS     17820000
         USING PERSAVW,7                                                18000000
         CLI   IDFLAG,0            FOLLOWING CODE ONLY FOR INCDUMP      18180000
         BE    DDM                                                      18360000
IDG      ST    7,IDNXPS            SAVE NEW PERSAVW ADDR AS NEXT        18540000
         MVC   LOSTPL,IDADPL       GLITCH FOR 'LOST WS' MESSAGES --     18720000
         MVC   IDADPL,TABTPSAV+4   MAKE SURE PERLIB ADDR LAGS BY ONE    18900000
         TS    IDAFLG              FIRST TIME THROUGH, SIMPLY COLLECT   19080000
         BZ    IDA                 A PERSAVW POINTER FOR PRESEEKING     19260000
*              AT THIS POINT, A POINTER TO PREVIOUS PERSAVW, LOADED     19440000
*              AT DDG, IS IN R8.                                        19620000
DDV      LR    7,8                 REST OF CODE KEEPS CURRENT PERSAVW   21600000
*                                  ADDR IN R7                           21780000
DDM      L     1,=A(UTFLAGS)       IF SINGLE WS BUFFERRING IS IN EFFECT 21960000
         TM    0(1),UT3WSS                                              22140000
         BNZ   DDM2                WAIT FOR DISK END TO START TAPE.     22320000
         ICALL DRDZ                                                     23220000
DDM2     CLI   REJECT-M(11),0      BYPASS TAPE WRITE IF WS IGNORED FOR  23400000
         BNZ   DDU                 ANY REASON                           23580000
         ICALL MTWR                                                     23760000
         ICALL MTWRZ                                                    23940000
         MVI   REJECT-M(11),1      BUFFER IS EMPTY                      24120000
DDU      L     1,PSCYL                                             DASD 24300000
         SR    0,0                                                 DASD 24480000
         IC    0,PSLEN                                             DASD 24660000
         A     0,WSTATS+4                                               24840000
         ST    0,WSTATS+4                                               25020000
         L     0,PSCYL                                             DASD 25200000
         C     0,WSTATS+8                                               25380000
         BL    *+8                                                      25560000
         ST    0,WSTATS+8                                               25740000
         L     0,WSTATS                                                 25920000
         A     0,=F'1'                                                  26100000
         ST    0,WSTATS                                                 26280000
         LH    2,PSFILE            FILE NUMBER                          26460000
         CLI   IDFLAG,0                                                 26640000
         BZ    DDE                 FOLLOWING IS FOR INCREMENTAL DUMP    26820000
         ICALL DRDR1               READ ONLY FIRST RECORD OF WS         27000000
         CLC   WFLNAME-M(16,11),PSNAME  SAME CHECK AS BELOW FOR FULL DM 27180000
         BNE   DDJ                                                      27360000
         CLC   RTS2+6(2),WFLDATE-M+6(11) COMPARING YY FIRST IS EASIER   27540000
         BH    DDQ                                                      27720000
         BL    IDB                 THAN REARRANGING DATE TO YYMMDD      27900000
         CLC   RTS2(12),WFLDATE-M(11)  DUMP THIS WS ONLY IF SAVED LATER 28080000
         BH    DDQ                 THAN TIME OF LAST FULL DUMP          28260000
IDB      ICALL DRDREST             IT WAS.  INITIATE READING OF REST    28440000
         L     1,IWSCNT            OF TRACKS.                           28620000
         LA    1,1(1)                                                   28800000
         ST    1,IWSCNT            UP COUNT OF DUMPED WORKSPACES        28980000
         B     DDK                                                      29160000
DDE      ICALL DRD                 READ ENTIRE WORKSPACE FOR FULL DUMP  29340000
*              NOTE.. WE ARE GUARANTEED OF HAVING FIRST RECORD IN CORE  29520000
*              WHEN DRD RETURNS, SO TESTS HERE ON WFLLIB ETC ARE OK.    29700000
         CLC   WFLNAME-M(16,11),PSNAME MAKE SURE WORKSPACE LABEL AGREES 29880000
         BE    DDK                 WITH DIRECTORY -- LIBRARY PACK HAS   30060000
DDJ      MVI   REJECT-M(11),1      BEEN OVERWRITTEN IF NOT.             30240000
DDK      CLI   REJECT-M(11),0                                           30420000
         BE    DDP                                                      30600000
         ICALL LOSTWS              WORKSPACE NOT READ CORRECTLY         30780000
DDQ      MVI   REJECT-M(11),1      OLD WS, NO DUMP.  REJECT QUIETLY.    30960000
         B     DDG                                                      31140000
DDP      L     11,ALTWS            SWAP WS ADDRESSES (NO EFFECT IF      31320000
         MVC   ALTWS(4),CURWS      SINGLE BUFFERRING)                   31500000
         ST    11,CURWS                                                 31680000
IDA      EQU   *                   END OF THIS DIR FOR INCDUMP          31860000
DDG      L     8,IDNXPS            FALL THROUGH IF PROCESSING           32040000
         LTR   8,8                 LAST WORKSPACE IN DIRECTORY          32220000
         BNZ   TABX                DURING INCDUMP                       32400000
         B     DDH                                                      32580000
         DROP  7                                                        32760000
DDB      SR    7,7                 FOR INCDUMP,                         32940000
         CLI   IDFLAG,0            NOTE NONEXISTENCE OF NEXT PERSAVW    33120000
         BNE   IDG                                                      33300000
DDH      LH    1,CURDIR            ADVANCE TO NEXT DIRECTORY            33480000
         LA    1,1(1)                                                   33660000
         C     1,HASHVAL                                                33840000
         BL    DDCS                                                     34020000
         ICALL DRDZ                UNBUFFER                             34920000
         CLI   REJECT-M(11),0      IF REJECTED, LOSE WS QUIETLY         35100000
         BNE   DDD2                                                     35280000
         ICALL MTWR                                                     35460000
         MVI   REJECT-M(11),1                                           35640000
DDD2     L     11,ALTWS                                                 35820000
         CLI   REJECT-M(11),0      NO EFFECT FOR SINGLE BUFFERRING      36000000
         BNE   DDC                                                      36180000
         ICALL MTWR                WRITE LAST WS                        36360000
         MVI   REJECT-M(11),1                                           36540000
DDC      ICALL MTWCLOSE            CLOSE OUTPUT TAPE                    36720000
         CLI   IDFLAG,0            IF FULL-DUMP,                        36900000
         BNE   DDC2                                                     37080000
         LR    11,10               REWRITE DIRECTORY 0                  37260000
         SR    1,1                                                      37440000
         ICALL DIRREAD             WITH THE TIME OF THE FULL DUMP.      37620000
         MVC   DFDTS(12),RTS                                            37800000
         SR    1,1                                                      37980000
         ICALL DIRWRT                                                   38160000
DDC2     EQU   *                                                        38340000
         MVC   DMNOWS(4),WSTATS    PRINT DUMP STATISTICS                38520000
         MVC   DMNOTR(4),WSTATS+4                                       38700000
         CLI   IDFLAG,0            INCDUMP PRINTS COUNT OF WSS ACTUALLY 38880000
         BZ    DDL                                                      39060000
         MVC   DMNIWS(4),IWSCNT                                         39240000
         ICALL OUTWRTL             DUMPED AS WELL AS NO. OF WORKSPACES  39420000
         DC    AL4(IDMSG)          IN SYSTEM.                           39600000
DDL      ICALL OUTWRTL                                                  39780000
         DC    AL4(DMSG)                                                39960000
         ICALL LCYLOG                                                   40140000
         IRETURN                                                        40320000
         SPACE 2                                                        40500000
DISUB    PROLOG                   , SET UP DUMP PARAMETERS              40680000
         LM    1,2,=A(TRECLEN,PARAMS+4)                                 40860000
         L     0,0(2)              PARAM 1 IS RECORD LENGTH             41040000
         ST    0,0(1)                                                   41220000
         C     0,TRLOW             MUST BE BETWEEN 500                  41400000
         BL    DISERR                                                   41580000
         CL    0,TRHIGH            AND 32K                              41760000
         BH    DISERR              OBJECT TO EXCESSIVE TAPE RECORD LGTH 41940000
         L     1,=A(TCCWARK-10)    COMPUTE (WITH A LITTLE SLOP) THE     42120000
         MR    0,0                 MAXIMUM WS SIZE THE SPECIFIED        42300000
*                                  BLOCK SIZE WILL PERMIT.              42480000
         L     2,=A(WSLEN)         IF WE CANNOT HANDLE OUR WS SIZE      42660000
         C     1,0(2)              WITH SPECIFIED BLOCK SIZE, REJECT.   42840000
         BH    DISB2                                                    43020000
DISERR   ICALL OUTWRTL             INVALID RECORD LENGTH PARAMETER      43200000
         DC    AL4(RLBMSG)                                              43380000
         ICALL CCREJ               ABNORMAL RETURN TO MAIN PROG         43560000
*                                                                       43740000
DISB2    ICALL MTWOPEN             OPEN OUTPUT TAPE FILE                43920000
         L     1,=A(KMANHASH)                                           44100000
         MVC   HASHVAL(4),0(1)     NO. OF DIRECTORIES                   44280000
         L     1,=A(WSLOC)                                              44460000
         MVC   DIRWS(12),0(1)      ADDRS OF 2 OR 3 BUFFER AREAS         44640000
         L     10,DIRWS                                                 44820000
         L     11,CURWS            MARK BUFFERS EMPTY                   45000000
         MVI   REJECT-M(11),1                                           45180000
         L     1,=A(UTFLAGS)                                            45360000
         TM    0(1),UT3WSS                                              45540000
         BZ    DISB3                                                    45720000
         L     11,ALTWS                                                 45900000
         MVI   REJECT-M(11),1                                           46080000
DISB3    ST    11,ALTWS            SAME AS CURWS IF SINGLE BUFFERRING   46260000
         IRETURN                                                        46440000
         SPACE 2                                                        46620000
IDFLAG   DC    X'00'               INCREMENTAL-DUMP FLAG                46800000
RTS      DC    3F'0'               OUR TIMESTAMP (WFLLIB FORMAT OF      46980000
*                                  CURRENT TIME)                        47160000
RTS2     DC    3F'0'               TIMESTAMP OF PREV FULL DUMP          47340000
IDNXPS   DC    A(0)                ADDR OF NEXT PERSAVW TO BE PRO-      47520000
*                                  CESSED BY INCDUMP, OR 0 IF           47700000
*                                  FINISHED WITH THIS LIBRARY.          47880000
IDADPL   DC    A(0)                PERLIB ADDRESS FOR NEXT PERSAVW      48060000
IWSCNT   DC    F'0'                NO. OF WORKSPACES ACTUALLY DUMPED    48240000
IDAFLG   DC    FL1'0'              1-ST-TIME SWITCH FOR INCDUMP         48420000
IDMSG    DC    X'10'                                                    48600000
DMNIWS   DC    C'0000'                                                  48780000
         DC    C' WORKSPACES DUMPED'                                    48960000
         DC    X'FF'                                                    49140000
DMSG     DC    X'10'               'NNN WORKSPACES NNN TRACKS'          49320000
DMNOWS   DC    C'0000'                                                  49500000
         DC    C' WORKSPACES '                                          49680000
         DC    X'10'                                                    49860000
DMNOTR   DC    C'0000'                                                  50040000
         DC    C' TRACKS '                                              50220000
         DC    X'FF'                                                    50400000
WSTATS   DC    3F'0'                                                    50580000
TRHIGH   DC    F'32750'            A LITTLE SLOP                        50760000
TRLOW    DC    F'500'                                                   50940000
RLBMSG   DC    C'INVALID RECORD LENGTH PARAMETER'                       51120000
         DC    X'FF'                                                    51300000
         TITLE 'SELECTIVE DUMP ROUTINE'                                 51480000
*                                                                       51660000
*        EXAMPLE OF UTILITY CARDS TO PREPARE A DISTRIBUTION TAPE:       51840000
*                                                                       52020000
*        *CARDS*                         *TAPE*                         52200000
*                                  WFLLIB  WFLNAME    WFLMAN            52380000
*                                                                       52560000
*        SELDUMP NNNN                                                   52740000
*        DIST                           0  *DIRECTORY*     0            52920000
*        (*) WSFNS                      1  WSFNS      314159            53100000
*        (*) NEWS                       1  NEWS       314159            53280000
*        (*) ADVANCEDEX                 1  ADVANCEDEX 314159            53460000
*        . . .                              . . .                       53640000
*        OPLIB                                                          53820000
*        (*) OPFNS                 314159  OPFNS      314159            54000000
*        . . .                              . . .                       54180000
*        END                                                            54360000
*                                                                       54540000
* NOTE.. (*) ABOVE MEANS ANY NUMBER MAY BE USED AS A LIBRARY NUMBER.    54720000
SELDUMP  PROLOG                                                         54900000
         ENTRY SELDUMP                                                  55080000
         ICALL DISUB                                                    55260000
         MVI   SDCRT+1,0                                                55440000
         MVI   SD4+1,X'F0'                                              55620000
         L     11,CURWS                                                 55800000
         USING M,11                                                     55980000
SDB      SR    0,0                 NO ERROR PREVIOUS CARD               56160000
SDA      LA    1,SDWSN             GET A LIB NO AND WSNAME FROM CARD    56340000
         ICALL SELCARD                                                  56520000
         TM    SDWSN,X'80'         LOOK FOR 'DIST' OR 'END'             56700000
         BZ    SDESZ2                                                   56880000
         CLC   SDWSN+WFLNAME-WFLLIB(4),=AL1(3,ZE,ZN,ZD)                 57060000
         BE    SD5                                                      57240000
         CLC   SDWSN+WFLNAME-WFLLIB(4),=AL1(3,ZEU,ZNU,ZDU) LOWERCASE    57420000
         BE    SD5                                                      57600000
         LA    0,1                 ASSUME ERROR ON PREVIOUS CARD        57780000
         CLC   SDWSN+WFLNAME-WFLLIB(5),=AL1(4,ZD,ZI,ZS,ZT)              57960000
         BE    SDCRT                                                    58140000
         CLC   SDWSN+WFLNAME-WFLLIB(5),=AL1(4,ZDU,ZIU,ZSU,ZTU)          58320000
         BE    SDCRT                                                    58500000
         CLC   SDWSN+WFLNAME-WFLLIB(6),=AL1(5,ZO,ZP,ZL,ZI,ZB)           58680000
         BE    SDISTX                                                   58860000
         CLC   SDWSN+WFLNAME-WFLLIB(6),=AL1(5,ZOU,ZPU,ZLU,ZIU,ZBU)      59040000
         BNE   SDA                 MUST BE ONE OF THE ABOVE             59220000
*        OPLIB  CARD INDICATES SELECTIONS WHICH FOLLOW GO TO OPR LIB    59400000
SDISTX   MVC   DISTLIB,OPNUM                                            59580000
         CLI   SD4+1,0             IF DIST CARD WAS ALREADY READ, OK.   59760000
         BE    SDB                                                      59940000
         EX    0,SDCRT             REJECT IF THIS IS NOT THE FIRST      60120000
         B     SDCRT2              SELECTION CARD.                      60300000
SDCRT    BC    0,SDA               **** PROG MODIFIED ****              60480000
         MVC   DISTLIB,=F'1'       PUT FOLLOWING SELECTIONS IN LIB 1    60660000
SDCRT2   MVI   SD4+1,0             FLIP DISTRIBUTION SWITCH $$$$$ $$$$$ 60840000
*                                                                       61020000
*        INITIAL DIRECTORY FOR DISTRIBUTED LIBRARY.                     61200000
*                                                                       61380000
         DROP  11                                                       61560000
         USING M,10                                                     61740000
         SR    1,1                 READ IN DIRECTORY.                   61920000
         ICALL DIRREAD                                                  62100000
         L     1,MANSTAR                                                62280000
         AR    1,10                                                     62460000
         LA    2,MANENTL                                                62640000
         B     DIST1+2                                                  62820000
         USING PERLIB,1                                                 63000000
DIST1    AR    1,2                                                      63180000
         CLC   LIBNUM(4),=F'-1'                                         63360000
         BNE   DIST1                                                    63540000
         SR    1,2                                                      63720000
         XC    PERLIB(MANENTL),PERLIB                                   63900000
         MVI   SRALIM,X'80'        INFINITE TIME LIMIT                  64080000
         MVC   LIBNUM,OPNUM                                             64260000
         MVC   HISNAME(12),OPNAME                                       64440000
         MVC   MANWSQ,=H'100'                                           64620000
         SR    1,2                                                      64800000
         XC    PERLIB(MANENTL),PERLIB                                   64980000
         MVC   LIBNUM,=F'1'                                             65160000
         SR    1,10                                                     65340000
         ST    1,MANSTAR                                                65520000
         XC    DFDTS(12),DFDTS     MAKE THIS LOOK LIKE A VERY OLD       65700000
         XC    DIDTS(12),DIDTS     FULL DUMP TAPE                       65880000
         AR    1,10                                                     66060000
         S     1,=F'256'                                                66240000
         XC    PERLIB(256),PERLIB  ZERO CONFIDENTIAL INFORMATION  FROM  66420000
         XC    FIRSTENT(256),FIRSTENT  THE DIRECTORIES OF THIS SYSTEM   66600000
         MVC   DSNXTF,=A(FIRSTENT-M)                                    66780000
         LR    11,10                                                    66960000
         ICALL MTWR                                                     67140000
         L     11,CURWS                                                 67320000
         DROP  1,10                                                     67500000
         B     SDB                                                      67680000
         USING M,11                                                     67860000
SDESZ2   EQU   *                                                        68040000
         MVI   SDCRT+1,X'F0'       ACCEPT NO 'DIST' CARDS               68220000
         L     1,SDWSN             RETRIEVE LIB NUMBER                  68400000
         SR    0,0                                                      68580000
         D     0,HASHVAL                                                68760000
         LR    1,0                                                      68940000
         ICALL DIRREAD             AND DIRECTORY                        69120000
         L     0,SDWSN                                                  69300000
         ICALL LOC8MAN                                                  69480000
         B     SDNM                NOT FOUND EXIT                       69660000
         LR    7,1                                                      69840000
         USING PERSAVW,7           SEARCH FOR WSNAME IN PERSAVWS        70020000
SD3      L     7,PSLINK                                                 70200000
         LTR   7,7                                                      70380000
         BZ    SDNW                WORKSPACE NOT FOUND                  70560000
         AR    7,10                                                     70740000
         CLI   SDWSN+4,0           NO CHECK ON WSNAME IF DUMPING ALL    70920000
         BE    SD7                                                      71100000
         CLC   PSNAME,SDWSN+4                                           71280000
         BNE   SD3                                                      71460000
SD7      L     1,PSCYL             READ WS FROM DISK               DASD 71640000
         LH    2,PSFILE            EXTENT NUMBER                        71820000
         ST    7,LOSTPL            SAVE PERSAVE ADDR FOR 'LOST' MSG     72000000
         STM   6,9,SDTEMP                                               72180000
         ICALL DRD                                                      72360000
         ICALL DRDZ                                                     73260000
         CLI   REJECT-M(11),0                                           73440000
         BNE   SD7A                DRD REJECTED WORKSPACE               73620000
         LM    6,9,SDTEMP                                               73800000
         CLC   WFLNAME(16),PSNAME  THOROUGH CHECK FOR RIGHT WS          73980000
         BE    SD4                                                      74160000
         MVI   REJECT-M(11),1                                           74340000
SD7A     ICALL LOSTWS              LOG 'WS LOST' IF NOT ALREADY DONE    74520000
         B     SD4B                                                     74700000
SD4      B     SD4A                PROGRAM MODIFIED.                    74880000
         CLC   WFLLIB(4),OPNUM                                          75060000
         BE    SD4A                DON'T CHANGE OPERATOR'S WSS.         75240000
         MVC   WFLLIB,DISTLIB                                           75420000
         MVC   WFLMAN,OPNUM        SAVED BY OPERATOR.                   75600000
SD4A     ICALL MTWR                                                     75780000
         ICALL MTWRZ                                                    75960000
         MVI   REJECT-M(11),0                                           76140000
SD4B     CLI   SDWSN+4,0                                                76320000
         BE    SD3                                                      76500000
         B     SDB                                                      76680000
SD5      ICALL MTWCLOSE                                                 76860000
         IRETURN                                                        77040000
         SPACE                                                          77220000
SDNM     MVC   SDMSG,=CL14'LIBRARY NUMBER'                              77400000
         B     SD8                                                      77580000
SDNW     CLI   SDWSN+4,0           NOT ERROR IF DUMPING ALL WSS,        77760000
         BE    SDB                 JUST FINISHED.                       77940000
         MVC   SDMSG,=CL14'WORKSPACE NAME'                              78120000
SD8      ICALL OUTWRTL                                                  78300000
         DC    AL4(SDMSG)                                               78480000
         BAL   0,SDA               GET NEXT INPUT FROM SYSLOG           78660000
SDMSG    DC    CL14'**************'                                     78840000
         DC    C' NOT FOUND'                                            79020000
         DC    CL5' '              SLOP                                 79200000
         DS    0F                  ALIGNMENT                            79380000
         ORG   *-5                 RESOLUTION                           79560000
         DC    X'11'               INTRODUCTION                         79740000
SDWSN    DS    4F                  LIB NO, WSNAME FROM SELECTION CARD   79920000
         DC    X'FF'                                                    80100000
OPNUM    DC    F'314159'                                                80280000
DISTLIB  DC    A(*-*)              DIST LIBRARY NUMBER                  80460000
OPNAME   DC    AL1(8,ZO,ZP,ZE,ZR,ZA,ZT,ZO,ZR,0,0,0)                     80640000
SDTEMP   DS    2D                                                       80820000
         DROP  7                                                        81000000
         DROP  11                                                       81180000
         TITLE 'LIBRARY TABLE TRACE ROUTINE'                            81360000
*                                                                       81540000
*        TRACE DOWN MAN LIST AND LIBRARY LIST FOR WORKSPACES.           81720000
*        FOR EACH SAVED WORKSPACE, RETURN TO 4(15) WITH ADDRESS OF      81900000
*        WORKSPACE ENTRY (PERSAVW) IN R7.  RETURN TO 0(15) WHEN DONE.   82080000
*        SAVES R15-R8.  USES R9 AS BASE.  R9 MUST NOT BE ALTERED BY     82260000
*        CODE AT 4(15).                                                 82440000
         USING M,10                                                     82620000
TABTRAC  BALR  9,0                                                      82800000
         USING *,9                                                      82980000
         STM   7,8,TABCRS                                               83160000
         ST    15,TABCRS+8                                              83340000
         L     8,MANSTAR                                                83520000
         AR    8,10                                                     83700000
         USING PERLIB,8                                                 83880000
TAB0     CLC   LIBNUM(4),=F'-1'                                         84060000
         BE    TAB2                                                     84240000
         LR    7,8                                                      84420000
         USING PERSAVW,7                                                84600000
TAB1     OC    PSLINK,PSLINK       LINK = 0 IS END OF LIST SIGNAL       84780000
         BE    TAB3                                                     84960000
         L     7,PSLINK                                                 85140000
         AR    7,10                                                     85320000
         STM   7,8,TABTPSAV        SAVE OWN REGISTERS                   85500000
         ST    8,LOSTPL                                                 85680000
         L     8,TABCRS+4          RESTORE CALLER'S REGISTERS           85860000
         L     15,TABCRS+8                                              86040000
         B     4(15)                                                    86220000
TABX     ST    8,TABCRS+4          4(15) CODE RETURNS HERE              86400000
         LM    7,8,TABTPSAV        BY  B TABX                           86580000
         B     TAB1                BY   B TABX                          86760000
TAB3     LA    8,MANENTL(8)                                             86940000
         B     TAB0                                                     87120000
TAB2     LM    7,8,TABCRS                                               87300000
         L     15,TABCRS+8                                              87480000
         BR    15                                                       87660000
TABCRS   DC    3F'0'               TABTRAC'S CALLER'S REGISTERS         87840000
TABTPSAV DC    2F'0'                                                    88020000
         DROP  10                                                       88200000
         DROP  9                                                        88380000
         DROP  8                                                        88560000
         DROP  7                                                        88740000
         TITLE 'PRINT LOST WORKSPACE MESSAGE'                           88920000
*              R7 = PERSAVW ADDR                                        89100000
*              R11= WS ADDR                                             89280000
*                                                                       89460000
LOSTWS   PROLOG                                                         89640000
         USING PERSAVW,7                                                89820000
         CLI   REJECT-M(11),2      NO MESSAGE IF REJECT=2               90000000
         BE    LOSTWS2             INDICATING MESSAGE ALREADY PRINTED   90180000
         L     1,LOSTPL            PERLIB ADDR FOR THIS PERSAVW CHAIN   90360000
         MVC   LWSD(4),LIBNUM-PERLIB(1)                                 90540000
         MVC   LWSD+4(12),PSNAME   SET UP FOR OUTWRT                    90720000
         LA    1,LWSD              LOC OF WSID                          90900000
         SR    0,0                 NO TIMESTAMP AVAILABLE               91080000
         LA    2,=CL9'REJECTED '   ACTION TAKEN                     A04 91260000
         LA    3,=XL1'FF'          NO SNAP ID                           91440000
         ICALL DWSLOG                                                   91620000
LOSTWS2  IRETURN                                                        91800000
LWSD     DC    XL16'00'                                                 91980000
LOSTPL   DC    A(0)                ADDR OF PERLIB FOR CURRENT PERSAVW   92160000
         DROP 7                                                         92340000
         EJECT                                                          92520000
*                                                                       92700000
HASHVAL  DC    F'0'                                                     92880000
DIRWS    DC    3A(0)                                                    93060000
CURWS    EQU   DIRWS+4                                                  93240000
ALTWS    EQU   DIRWS+8                                                  93420000
REJECT   EQU   M                   ********** NOTE -- WE ASSUME THAT    93600000
*                                  ********** BYTE 0 OF SAVED REG 0     93780000
*                                  ********** IS IRRELEVANT             93960000
CURDIR   DC    H'0'                                                     94140000
UT3WSS   EQU   X'40'               UTFLAGS MASK - DOUBLE BUFFERING      94320000
TCCWARK  EQU   200                 MAG TAPE CCW COUNT (FROM MTSECT)     94500000
         LTORG                                                          94680000
         COPY  DIRSECT                                                  94860000
         END                                                            95040000
./  ADD    NAME=APLUMAIN
MAIN     TITLE 'A P L   U T I L I T Y   I N I T I A L I Z A T I O N '   00090000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00180000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00270000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00360000
         MACRO                                                          00450000
&L       CMD   &TXT,&LOC,&PARS,&FLAGS                                   00540000
&L       DC    CL8'&TXT'                                                00630000
         DC    AL1(&FLAGS)                                              00720000
         DC    AL3(&LOC)                                                00810000
         DC    F'&PARS'                                                 00900000
         MEND                                                           00990000
*                                                                       01080000
*                                                                       01530000
         PRINT OFF                 COPY APLDEFN ZSYMBOLS                01620000
         COPY  APLDEFN                                                  01710000
         COPY ZSYMBOLS                                                  01800000
         TITLE 'A P L   U T I L I T Y   C O N T R O L         05/11/70' 01890000
         PRINT ON                                                       01980000
         DROP  11                                                       02070000
         EXTRN ADPAR                                                    02160000
         ENTRY APLMODAD                                                 02250000
         EXTRN BILL                                                     02340000
         EXTRN CDCAD                                                    02430000
         ENTRY CMD                                                      02520000
         EXTRN CREATE                                                   02610000
         EXTRN DIRREAD                                                  02700000
         EXTRN DIRSET                                                   02790000
         EXTRN DDUMP                                                    02880000
         EXTRN DIRWRT                                                   02970000
         EXTRN DREST                                                    03060000
         EXTRN FMTDSK                                                   03150000
         EXTRN IDUMP                                                    03240000
         EXTRN KMANHASH                                                 03330000
         EXTRN OPLIB               OPEN ALL LIBRARY PACKS               03420000
         EXTRN OUTWRT                                                   03510000
         EXTRN OUTWRTL                                                  03600000
         ENTRY PARAMS                                                   03690000
         EXTRN RETRIEVE                                                 03780000
         EXTRN SELDUMP                                                  03870000
         EXTRN SELREST                                                  03960000
         EXTRN TVERIFY                                                  04050000
         ENTRY UTDATE                                                   04140000
         EXTRN UTCARD                                                   04230000
         ENTRY UTFLAGS                                                  04320000
         EXTRN VERIFY                                                   04410000
         EXTRN WSLEN                                                    04500000
         EXTRN ZTOV                                                     04590000
*                                                                       04680000
*        INITIAL ENTRY TO APL UTILITIES                                 04770000
*                                                                       04860000
MAIN     CSECT                                                          04950000
         SR    15,15               PROVIDE A ZERO RETURN CODE      2214 05400000
         STM   14,12,12(13)        SAVE OS REGISTERS                    05490000
         BALR  12,0                ADDRESSABILITY                       05580000
         USING *,12                                                     05670000
         LA    10,4092(12)         SECOND BASE REGISTER.                05760000
         USING *+4092-4,10                                              05850000
         ST    13,OSLINK           SAVE OS SAVE AREA ADDRESS            08370000
         LM    2,5,DCBADS          OPEN LST,RDR,PCH,WSDUMP              08460000
         OPEN  ((2),(OUTPUT),(3),,(4),(OUTPUT),(5),(OUTPUT))            08550000
         USING IHADCB,2                                                 08640000
         TM    DCBOFLGS,X'10'      ENSURE THAT SYSLST WAS OPENED        08730000
         BO    GETCORE       OPEN WAS SUCCESSFUL                   2214 08820000
         WTO   'APL     SYSPRINT DDCARD MISSING',ROUTCDE=(1,11)     K19 08910000
         B     CANCEL                                                   09000000
         DROP  2                                                        09090000
         SPACE 2                                                   2214 09180000
GETCORE  EQU   *                                                   2214 09270000
         SPACE 1                                                   2214 09450000
         L     1,=A(WSLEN)         GET WSLEN FROM CONFIG           2214 09540000
         L     1,0(1)                                              2214 09630000
         LA    1,7(1)              ROUND UP TO DOUBLE WORD         2214 09720000
         N     1,=F'-8'                                            2214 09810000
         ST    1,WLEN                                              2214 09900000
         SPACE 2                                                   2214 09990000
         LA    2,1016+3*32(1,1)    CALCULATE MAXIMUM CORE THAT CAN 2214 10170000
         AR    2,1                 BE USED = 1000+3*WSLEN+32       2214 10260000
         LA    1,1016+32(1)  SET UP PROPER MINIMUM                 2214 10350000
         STM   1,2,SPACE     SAVE MIN AND MAX FOR GETMAIN          2214 10440000
         GETMAIN VU,LA=SPACE,A=WSLOC GET AS MUCH SPACE AS IS USAB  2214 10530000
         L     13,WSLOC      TEMP R13 FOR ERROR MESSAGES           2214 10620000
         LR    14,13           DUMMY START OF STACK ENTRY          2214 10710000
         USING IHADCB,3                                                 10800000
TRYRDR   TM    DCBOFLGS,X'10'      WAS RDR OPENED                       10890000
         BO    TRYPCH              CONTINUE IF YES                      10980000
         ICALL OUTWRT                                                   11070000
         DC    AL4(NORDRMSG)                                            11160000
         B     CANCEL                                                   11250000
         DROP  3                                                        11340000
         USING IHADCB,4                                                 11430000
TRYPCH   TM    DCBOFLGS,X'10'                                           11520000
         BO    GETTIME             UREC FILES ALL OPENED CORRECTLY      11610000
         MVI   NOBILL,X'FF'        NO PUNCH - PROHIBIT BILLING          11700000
*                                                                       11790000
*              CONVERT CURRENT DATE TO APL FORM AVOIDING THE USE OF     11880000
*              PACKED DECIMAL ARITHMETIC FOR THE SAKE OF THE MODEL 91   11970000
*                                                                       12060000
GETTIME  TIME  DEC                 GET PACKED DATE                      12150000
         ST    1,DATE              AND                                  12240000
         STH   1,DAY+6             SAVE IT                              12330000
         CVB   1,DAY               FORM BINARY DAY OF YEAR              12420000
         LM    2,5,INDEX           INDICES FOR CALCULATING MONTH        12510000
         TM    DATE+1,X'01'        CHECK FOR LEAP YEAR                  12600000
         BO    CMP                 THIS IS AN ODD YEAR                  12690000
         TM    DATE+1,X'12'        FIND EVEN NON LEAP YEARS. THIS       12780000
         BM    CMP                 CODE IS VALID UNTIL THE YEAR 2100    12870000
         CH    1,NUMTH+2(4)        A LEAP YEAR. IS THIS BEFORE FEB 29TH 12960000
         BL    CMP                 YES                                  13050000
         BZ    PRT                 NO, BUT IT IS FEB 29TH               13140000
         BCTR  1,0                 DATE AFTER 29TH FEB IS 1 DAY TOO HI  13230000
CMP      CH    1,NUMTH(4)          IS DAY IN THIS MONTH                 13320000
         BL    DEC                 EXIT FROM SEARCH IF YES              13410000
         BXLE  4,2,CMP             GO TEST NEXT MONTH IN LIST TO DEC.   13500000
DEC      SR    4,2                 ADJUST MONTH                         13590000
PRT      SH    1,NUMTH(4)          FORM DAY OF MONTH                    13680000
         AH    1,NUMTH                                                  13770000
         AR    2,4                 FORM BINARY DATE                     13860000
         MR    4,2                 (100*MONTH)+DAY                      13950000
         AR    1,5                                                      14040000
         CVD   1,DECDT             PACKED DECIMAL DATE IN FORM          14130000
         MVC   DECDT+4(1),DATE+1   YY0MMDDS                             14220000
         OI    DECDT+7,X'0F'                                            14310000
         L     2,=A(UTDATE)                                             14400000
         UNPK  DATE(7),DECDT+4(4)  WITH INTERSPERSED SLASHES            14490000
         MVC   0(8,2),=AL1(3,4,7,5,6,7,0,1)                             14580000
         TR    0(8,2),DATE                                              14670000
         SPACE 3                                                   2214 14760000
*   SUBALLOCATE THE CORE AVAILABLE TO THE APL UTILITY              2214 14850000
         LM    2,3,WSLOC           GET LAST BYTE OF CORE PLUS ONE       14940000
         AR    2,3                                                 2214 15030000
         ST    2,SPACE                                             2214 15120000
         LA    2,0(2)                                              2214 15300000
         S     2,=F'1000'          ALLOW LOTS OF ROOM FOR R13 STACK     15390000
         L     1,WLEN              GET WORKSPACE SIZE              2214 16020000
*              ADD START OF WS1 PLUS                               2214 16470000
         LA    1,32(1,13)    TAPE IO OVERSHOOT AREA                2214 16560000
         ST    1,WSLOC+4           START OF WS AREA 2                   16650000
         CR    2,1                 MAKE SURE WE HAVE ENOUGH CORE TO     16740000
         BH    MAINE               RUN THE UTILITY AT ALL               16830000
         ICALL OUTWRTL       INSUFFICIENT CORE STORAGE             2214 16920000
         DC    AL4(OVFMSG)                                              17010000
CANCEL   CANCEL ,                  THERE ARE NO REASONS TO CONTINUE.    17100000
MAINE    A     1,WLEN              ADD IN WS LENGTH                     17190000
         LA    1,32(1)             TAPE IO MAY OVERSHOOT BY 24          17280000
         ST    1,WSLOC+8           START OF WS AREA 3                   17370000
         CR    2,1                 EVEN IF WE HAVE ROOM FOR ONLY A      17460000
         BH    MAINC               SINGLE WS AREA, SOME COMMANDS WILLGO 17550000
         NI    UTFLAGS,255-UT2WSS  TURN OFF 2 WSS SWITCH                17640000
         L     1,WSLOC+4                                                17730000
         OI    WSLOC+5,X'80'  NO LONGER A VALID ADDRESS            2214 17820000
         B     MAINC2        THERE WONT BE ENOUGH FOR 3 EITHER     2214 17910000
MAINC    A     1,WLEN              ADD IN WS LENGTH                     18000000
         LA    1,32(1)             TAPE IO MAY OVERSHOOT BY 24          18090000
         CR    2,1                 IF WE HAVE ENOUGH CORE LEFT, LET'S   18180000
         BH    MAIND                 USE IT TO DOUBLE BUFFER WSS        18270000
         L     1,WSLOC+8     END OF SECOND SLOT                    2214 18360000
MAINC2   EQU   *                                                   2214 18450000
         OI    WSLOC+9,X'80'  NO LONGER A VALID ADDRESS            2214 18540000
         NI    UTFLAGS,255-UT3WSS  TURN OFF 3 WSS SWITCH                18630000
MAIND    LR    13,1                ESTABLISH REAL R13 STACK             18720000
         LA    14,16(13)             WITH DUMMY FIRST ENTRY        2214 18810000
         MVC   0(12,13),=3A(X'800000')    DUMMY FIRST ENTRY        2214 18900000
         LA    1,1000(14)          CHECK IF SPACE REQD BYT UTILITY      19620000
         L     0,SPACE             IS LESS THAN THAT ASSIGNED BY GETMN  19710000
         SR    0,1                                                      19800000
         BNH   NOFREE              SKIP IF NOT                          19890000
         FREEMAIN R,LV=(0),A=(1)   IS NOT REQUIRED                      19980000
NOFREE   EQU   *                                                        20070000
         ICALL OUTWRT              PRINT A TIMESTAMP                    20250000
         DC    AL4(MATOD)                                               20340000
         BAL   12,MA0        ESTABLISH NEW BASE,  START RUN        2214 20430000
         USING *,12          TELL ASSEMBLER THAT WE HAVE ADDRESS   2214 20520000
         DROP  10            GET RID OF OLD SECOND BASE REG        2214 20610000
NOCORE   ICALL OUTWRTL       INSUFFICIENT CORE STORAGE MESSAGE     2214 20700000
         DC    AL4(OVFMSG)                                         2214 20790000
         CANCEL ,            TERMINATE THIS RUN OF THE UTILITY     2214 20880000
         SPACE 3                                                   2214 20970000
APLMODAD DC    F'0'                                                2214 21060000
         SPACE 3                                                   2214 21150000
MA0      STM   12,14,MASRS   SAVESTART OF STACK POINTERS FOR       2214 21240000
*                  USE BY CCREJ IF CONTROL CARD REJECTED           2214 21330000
         TITLE 'A P L   U T I L I T Y   C O N T R O L '            2214 21420000
MA1      EQU   *                                                   2214 21510000
         SR    0,0                 ASSUME NO ERROR, PREV CONTROL CARD.  21600000
MA8      EQU   *                                                   2214 21690000
         L     1,=A(DIRWRT)        RE-ENABLE DIRECTORY WRITES           21780000
         NI    1(1),X'0F'          IN CASE WE FOLLOW TESTBILL COMMAND   21870000
         DEQ   (QNAME,RNAME,,SYSTEM),RET=HAVE                           22140000
*        ENSURE APLOS360.LIBRARIES IS NOT ASSIGNED TO APLUTIL           22230000
         LA    1,CARD                                                   22320000
         ICALL UTCARD                                                   22410000
         B     EOJ                 END-FILE RETURN                      22500000
         LA    6,CARD              SET UP FOR CARD SCAN                 22590000
         MVI   0(TLR),C' '         BUILD 80 CHARS OF BLANKS TO OR       22680000
         MVC   1(79,TLR),0(TLR)    LOWERCASE EBCDIC ALPHAS INTO UPPER   22770000
         OC    CARD(80),0(TLR)                                          22860000
MA2      CLI   0(6),C' '           SKIP TO FIRST NONBLANK COLUMN        22950000
         BNE   MA3                                                      23040000
         LA    6,1(6)                                                   23130000
         B     MA2                                                      23220000
MA3      CLI   0(6),X'FF'          CHECK FOR END OF CARD                23310000
         BE    MA1                 TOTALLY BLANK                        23400000
         LM    0,2,CMDSCN                                               23490000
         LR    7,6                 SAVE COMMAND START COLUMN            23580000
         MVC   CMD(8),=XL8'0'      CLEAR COMMAND WORK AREA         2531 23670000
VS8      LA    7,1(7)              SCAN TO END OF COMMAND               23760000
         CLI   0(7),C' '                                                23850000
         BNE   VS8                 FIRST SKIP COMMAND,                  23940000
         LR    5,7                                                      24030000
         SR    5,6                 COMMAND LENGTH                       24120000
         BCTR  5,0                 SS                                   24210000
MA4      EX    5,MACLC                                                  24300000
         BE    MA5                                                      24390000
MA13     BXLE  2,0,MA4             GO SCAN NEXT TABLE ENTRY        2531 24480000
         EX    0,MA5               WERE THERE ANY MATCHES          2531 24570000
         BNE   MA12                BRANCH IF VALID COMMAND         2531 24660000
MBC      ICALL OUTWRTL             BAD COMMAND.  NOTE ON SYSLOG         24750000
         DC    AL4(MATX)                                                24840000
         BAL   0,MA8               READ NEXT CARD FROM SYSLOG           24930000
EOJ      EOJ                                                            25020000
MACLC    CLC   0(0,6),0(2)                                              25110000
MA5      CLC   CMD(8),=XL8'0'      IS THIS THE FIRST MATCH         2531 25200000
         BNE   MBC                 NO-- ABBREV COMMAND NOT UNIQUE  2531 25290000
         MVC   CMD(8),8(2)         MOVE TABLE ENTRY TO WORK        2531 25380000
         B     MA13                FINISH TABLE SCAN               2531 25470000
MA12     EQU   *                                                   2531 25560000
         L     6,CMD+4                                                  25650000
         LTR   6,6                                                      25740000
         BZ    MA7                 ZERO PARAMETERS                      25830000
         LR    6,7                                                      25920000
VS9      LA    6,1(6)                                                   26010000
         CLI   0(6),C' '           SKIP BLANKS FOLLOWING COMMAND        26100000
         BE    VS9                                                      26190000
         LA    4,PARAMS+4                                               26280000
         XC    PARAMS(76),PARAMS                                        26370000
         B     VS10                                                     26460000
VS11     LA    6,1(6)              SKIP OVER COMMA                      26550000
VS10     CLC   0(2,6),=C'X'''      IS NEXT OPERAND HEX --               26640000
         BE    VS3                                                      26730000
         LR    7,6                 NO.  RECORD START ADDRESS.           26820000
VS1      CLI   0(6),C'0'                                                26910000
         BL    VS2                 SKIP TO END OF DECIMAL NUMBER        27000000
         CLI   0(6),X'FF'          ARE WE AT END OF BUFFER              27090000
         BE    VS2                 YES, COLLECT LAST DIGIT              27180000
         LA    6,1(6)                                                   27270000
         B     VS1                                                      27360000
VS3      LA    6,2(6)              HEX CONVERSION.  SKIP X'             27450000
         LR    7,6                                                      27540000
VS4      CLI   0(6),C''''          HAVE WE REACHED END --               27630000
         BE    VS5                 YES.                                 27720000
         CLI   0(6),X'FF'          ARE WE AT END OF CARD                27810000
         BE    MBC                 YES, ERROR. HE FORGOT ENDING '       27900000
         CLI   0(6),C'0'           NO, IS NEXT CHAR NUMERIC             27990000
         BNL   VS6                 YES                                  28080000
         CLI   0(6),C'F'           IT HAD BETTER BE ABCDEF              28170000
         BH    MBC                                                      28260000
         CLI   0(6),C'A'                                                28350000
         BL    MBC                                                      28440000
         IC    5,0(6)              MAKE LOW-ORDER 4 BITS                28530000
         LA    5,X'FF'-C'F'(5)     HEX ABCDEF                           28620000
         STC   5,0(6)                                                   28710000
VS6      LA    6,1(6)                                                   28800000
         B     VS4                                                      28890000
VS5      SR    6,7                                                      28980000
         CL    6,=F'8'                                                  29070000
         BH    MBC                 NO MORE THAN 8 DIGITS                29160000
         EX    6,VSHPK             PACK TO A 4-BYTE NUMBER WITH FIFTH   29250000
         L     0,VTEMP             GARBAGE BYTE IGNORED                 29340000
         B     VS7                 REJOIN COMMON CODE                   29430000
VS2      SR    6,7                 GET CONSTANT LENGTH                  29520000
         BCTR  6,0                 SS FORMAT                            29610000
         CL    6,=F'9'             NOTE CHECK HERE FOR NONEXISTENT CON  29700000
*                                  MAPPED INTO COUNT OF -1              29790000
         BH    MBC                                                      29880000
         EX    6,VSDPK             PACK CONSTANT                        29970000
         CVB   0,VTEMP             AND CONVERT.                         30060000
VS7      ST    0,0(4)              REENTRY FOR HEX CONSTANTS            30150000
         LA    4,4(4)              BUMP TO NEXT OPERAND LOCATION        30240000
         LA    6,1(6,7)            RESTORE CHARACTER POINTER            30330000
         CLI   0(6),C','           IS NEXT CHAR A COMMA --              30420000
         BE    VS11                YES.  CONVERT ANOTHER OPERAND.       30510000
         CLI   0(6),C' '           IT HAD BETTER BE A BLANK             30600000
         BE    VS12                                                     30690000
         CLI   0(6),X'FF'          OR COLUMN 81                         30780000
         BNE   MBC                                                      30870000
VS12     S     4,=A(PARAMS+4)                                           30960000
         SRL   4,2                 FIND NUMBER OF OPERANDS CONVERTED    31050000
         L     1,=A(PARAMS)                                             31140000
         ST    4,0(1)                                                   31230000
         CL    4,CMD+4             IS IT SUFFICIENT --                  31320000
         BL    MBC                 NO.                                  31410000
*        LOCATE APL LIBRARY USING VTOC                                  31500000
MA7      TS    OPFLAG              ARE LIBRARIES OPEN                   31590000
         BNZ   SKPOPN              DO IT ONLY ONCE                      31680000
         ICALL OPLIB               OPEN ALL LIBRARIES                   31770000
SKPOPN   L     2,=A(CDCAD)                                              31860000
         USING CDCAD,2                                                  31950000
         USING CDCPARS,8                                                32040000
         L     8,=A(ADPAR)                                              32130000
         L     8,0(8)                                                   32220000
         MVC   CDCAD+4(4),TLENF                                         32310000
         DROP  2,8                                                      32400000
         TM    CMD,CMWAPL          IF COMMAND IS ALLOWED WHILE APL      32490000
         BO    MA9                 IS RUNNING, OK.                      32580000
         ENQ   (QNAME,RNAME,E,,SYSTEM),RET=USE                          34830000
*        ASSIGN APLOS360.LIBRARIES TO APLUTIL IF POSSIBLE               34920000
         LTR   15,15               WAS IT ASSIGNED                      35010000
*        IF IT WAS NOT, THEN PRESUMABLY APL PROGRAM HAS IT              35100000
         BE    MA9                 BRANCH IF APL NOT RUNNING            35190000
MA9B     MVC   MATX,=C'INVALID -- APL RUNNING '                         35370000
         ICALL OUTWRTL             NOTE REJECTION ON SYSLOG.            35460000
         DC    AL4(MATX)                                                35550000
         MVC   MATX,=C'INCORRECT CONTROL CARD '                         35640000
         BAL   0,MA8               GIVE OPERATOR A CHANCE TO FIX IT UP  35730000
MA9      TM    CMD,CMNORD          SHOULD WE SKIP DIRECTORY READ --     35820000
         BO    MA6                 YES                                  35910000
         ICALL DIRSET                                                   36000000
MA6      TM    CMD,CM1WS           IF THIS COMMAND USES ONLY 1 WS, WE   36090000
         BO    MA11                KNOW WE HAVE ENOUGH CORE.            36180000
         TM    UTFLAGS,UT2WSS      ALL COMMANDS WILL WORK WITH 2 SLOTS  36270000
         BZ    NOCORE              ONLY 1 SLOT, CANCEL WITH ERR MSG     36360000
MA11     L     1,CMD               CALL APPROPRIATE ROUTINE             36450000
         TM    CMD,CMPCH                                                36630000
         BZ    EXECRT              BRANCH IF NO PUNCH IS REQUIRED.      36720000
CHKPCH   CLI   NOBILL,0            PUNCH MUST BE AVAILABLE FOR BILLING  36810000
         BE    EXECRT              OR TESTBILLING                       36900000
         ICALL OUTWRTL                                                  36990000
         DC    AL4(NOBILMSG)                                            37080000
         B     MA1                                                      37170000
EXECRT   EQU   *                                                        37260000
         TM    CMD,CMMOD                                                37350000
         BZ    MA10                                                     37440000
         CLC   APLMODAD,=F'0'                                           37530000
         BZ    MBC                                                      37620000
MA10     BALR  15,1                                                     37710000
         B     MA1                                                      37800000
         SPACE 2                                                        37890000
         USING WSLIST,1                                                 37980000
WSLIST   OI    UTFLAGS,UTWSLST     ASK MTSECT TO LOG WS FILE LABEL IN   38070000
         BR    15                  DUMP OR RESTORE OPERATIONS           38160000
         DROP  1                                                        38250000
         SPACE 2                                                        38340000
         USING WSDUMP,1                                                 38430000
         USING IHADCB,6                                                 38970000
WSDUMP   L     6,=A(WSDMPDCB)      ADDR OF WSDUMP DCB                   39060000
         TM    DCBOFLGS,X'10'      WAS DCB OPENED SUCCESSFULLY?         39150000
         BO    WSDUMPOK            BRANCH IF YES                        39240000
         LR    6,15                SAVE RETURN REG THRU ICALL           39330000
         ICALL OUTWRT              NO, PUT NASTY MESSAGE ON SYSPRINT    39420000
         DC    AL4(WSDMPERR)        AND CONTINUE WITHOUT WSDUMP.        39510000
         BR    6                   RETURN TO CALLER                     39600000
WSDUMPOK OI    UTFLAGS,UTWSDMP     SET FLAGS TO CAUSE REJECTED WS       39690000
*                                   TO BE DUMPED IN HEX.                39780000
         BR    15                  RETURN TO CALLER                     39870000
         DROP  6                                                        39960000
         DROP  1                                                        40140000
         SPACE 2                                                        40230000
         ENTRY CCREJ               RE-ENTRY AFTER CONTROL CARD REJECTED 40320000
CCREJ    BALR  1,0                 BY ONE OF MAIN'S SUBROUTINES         40410000
*                                  E.G. DUMP DOESN'T LIKE RECORD LGTH   40500000
         USING *,1                                                      40590000
         LM    12,14,MASRS         RECALL R13 STACK POSITION            40680000
         DROP  1                                                        40770000
         BAL   0,MA8               READ NEXT CARD FROM SYSLOG           40860000
*                                                                       40950000
*                                                                       41040000
         USING INHIB,1             DO A TEST BILLING                    41130000
INHIB    ICALL OUTWRTL             DON'T LOSE OUR INTEGRITY WITHOUT     41220000
         DC    AL4(TBWARN)         A STRUGGLE                           41310000
         L     2,=A(DIRWRT)                                             41400000
         OI    1(2),X'F0'          INHIBIT DIRECTORY WRITES             41490000
         L     1,=A(BILL)          THEN BEHAVE LIKE BILLING COMMAND     41580000
         DROP  1                                                        41670000
         B     MA10                                                     41760000
TBWARN   DC    C'APL BILLING TEST -- USE OUTPUT ONLY FOR DEBUGGING'     41850000
         DC    X'FF'                                                    41940000
*                                                                       42030000
CMDSCN   DC    A(16,CMDE,CMDT)                                          42120000
*                      COMMAND BIT MEANINGS --                          42210000
CMNORD   EQU   X'80'               SKIP DISK DIRECTORY READ             42300000
CMWRD    EQU   X'40'               REWRITE DISK DIRECTORIES             42390000
CMRST    EQU   X'20'               RESET ACCOUNTING INFORMATION         42480000
CMMOD    EQU   X'10'               ALTER EACH WORKSPACE DURING RESTORE  42570000
CMWAPL   EQU   X'08'               ALLOW COMMAND WHILE APL IS RUNNING   42660000
CMPCH    EQU   X'04'               THIS OPERATION PUNCHES CARDS         42750000
CM1WS    EQU   X'02'               ONLY 1 WS SLOT NEEDED                42840000
CMDT     CMD   DUMP,DDUMP,1,0                                           42930000
         CMD   INCDUMP,IDUMP,1,0                                        43020000
         CMD   RESTORE,DREST,0,CMNORD+CMWRD                             43110000
         CMD   ACCTG,ACCOUNT,1,CMWAPL                                   43200000
         CMD   BILLING,BILL,0,CMWRD+CMRST+CMPCH                         43290000
         CMD   DISKFMT,FMTDSK,1,CMNORD                                  43380000
         CMD   CREATE,CREATE,0,CMNORD+CMWRD                             43470000
         CMD   SELREST,SELREST,0,CMWRD                                  43560000
         CMD   SELDUMP,SELDUMP,1,CMNORD+CMWAPL                          43650000
         CMD   RETRIEVE,RETRIEVE,0,CMWRD                                43740000
         CMD   TESTBILL,INHIB,0,CMWAPL+CMPCH                            43830000
         CMD   TVERIFY,TVERIFY,0,CMNORD+CMWAPL                     2214 43920000
         CMD   VERIFY,VERIFY,1,CMNORD+CMWAPL                            44010000
         CMD   WSLIST,WSLIST,0,CMNORD+CMWAPL+CM1WS                      44100000
         CMD   WSDUMP,WSDUMP,0,CMNORD+CMWAPL+CM1WS                      44190000
CMDE     EQU   *-1                                                      44280000
MASRS    DC    3F'0'               SAVED R12, R13, R14 FOR MAIN         44370000
VSDPK    PACK  VTEMP(8),0(0,7)                                          44460000
VSHPK    PACK  VTEMP(5),0(0,7)                                          44550000
VTEMP    DC    D'0'                                                     44640000
UTDATE   DC    CL8' '              MM/DD/YY IN EBCDIC FOR UTILITY       44730000
CMD      DC    2F'0'               UTILITY COMMAND WORK AREA       2531 44820000
MATOD    DC    X'14FF'             'PAGE HEADING' IN MIDDLE OF PAGE     44910000
UTFLAGS  DC    AL1(UT2WSS+UT3WSS)  UTILITY FLAG BYTE                    45000000
UTWSLST  EQU   X'80'               WSLIST FLAG                          45090000
UT3WSS   EQU   X'40'               DOUBLE BUFFERING FLAG (3 WS SLOTS)   45180000
UTWSDMP  EQU   X'20'               DUMP REJECTED WSS TO SYSLST          45270000
UT2WSS   EQU   X'10'               SINGLE BUFFERING FLAG (2 WS SLOTS)   45360000
NOBILL   DC    X'00'                                                    45450000
OPFLAG   DC    X'00'                                                    45540000
*        ENTRY POINTS REQUIRED UNDER OS FOR OPLIB,NOPEN,DSKFMT          47250000
         EXTRN LIBPZ,LIBPARS,APLSDCBS,DIRTAB                            47340000
         ENTRY ALIBPZ,ALIBPARS,AAPLSDCB,AMANHASH,AWSLEN,ADIRTAB         47430000
ALIBPZ   DC    A(LIBPZ)                                                 47520000
ALIBPARS DC    A(LIBPARS)                                               47610000
AAPLSDCB DC    A(APLSDCBS)                                              47700000
AMANHASH DC    A(KMANHASH)                                              47790000
AWSLEN   DC    A(WSLEN)                                                 47880000
ADIRTAB  DC    A(DIRTAB)                                                47970000
*        ERROR MESSAGE FOR APL UNDER OS                                 48060000
NORDRMSG DC    C'SYSIN DD STATEMENT OMITTED'                            48150000
         DC    X'FF'                                                    48240000
NOBILMSG DC    C'NO BILLING - SYSPUNCH DD STATEMENT OMITTED'            48330000
         DC    X'FF'                                                    48420000
WSDMPERR DC    C'UNABLE TO OPEN WSDUMP DATA SET -- WSDUMP CONTROL CARD X48510000
               IGNORED'                                                 48600000
         DC    X'FF'                                                    48690000
*        DATA REQD BY OS MAIN ONLY                                      48780000
SPACE    DC    A(8,X'FFFFF8')                                           48870000
DCBADS   DC    A(PRTDCB,RDRDCB,PCHDCB,WSDMPDCB)                         48960000
         EXTRN PRTDCB,RDRDCB,PCHDCB,WSDMPDCB                            49050000
QNAME    DC    C'APLOS360'                                              49140000
RNAME    DC    C'LIBRARIES'                                             49230000
OSLINK   DS    F                                                        49320000
DECDT    DS    D                                                        49410000
DAY      DC    D'0'                                                     49500000
DATE     DS    CL7                                                      49590000
         DC    C'/'                                                     49680000
INDEX    DC    A(2,22,2,50)                                             49770000
NUMTH    DC    H'1,32,60,91,121,152,182,213,244,274,305,335'            49860000
MATX     DC    C'INCORRECT CONTROL CARD ' MUST PRECEDE 'CARD'           50040000
CARD     DS    80C                                                      50130000
         DC    X'FF'               COL 81                               50220000
OVFMSG   DC    C'INSUFFICIENT CORE STORAGE'                             50310000
         DC    X'FF'                                                    50400000
         DCBD  DSORG=PS,DEVD=DA                                         50670000
MAIN     CSECT                                                          50760000
         TITLE 'APL UTILITY ACCOUNTING SUMMARY                05/11/70' 50940000
*                                                                       51030000
*        PRINT ACCOUNTING INFORMATION ON SYSLST.                        51120000
         USING M,11                                                     51210000
ACCOUNT  PROLOG                                                         51300000
         L     1,=A(KMANHASH)                                           51390000
         L     1,0(1)                                                   51480000
         ST    1,MANHASH                                                51570000
         L     1,AWS1                                                   51660000
         A     1,ACTWL                                                  51750000
         S     1,=A(MANENTL)                                            51840000
         ST    1,ACTSZ                                                  51930000
         LA    3,MANENTL+5*PSWL    GUESS THE APPROPRIATE NUMBER OF      52020000
*                                  ENTRIES TO EXTRACT FROM EACH DIR     52110000
         M     2,MANHASH           5 WS PER MAN IS REASONABLE AVERAGE   52200000
         S     1,AWS1              EFFECTIVE WS LENGTH                  52290000
         SR    0,0                                                      52380000
         DR    0,3                                                      52470000
         ST    1,ACTDIV                                                 52560000
         XC    TCUMCON(16),TCUMCON                                      52650000
         XC    TWSS(16),TWSS       CLEAR COUNTERS INITIALLY             52740000
         ICALL DIRSET                                                   52830000
         ICALL OUTWRT              PRINT HEADING                        52920000
         DC    AL4(ACHD)                                                53010000
         USING PERLIB,2                                                 53100000
         L     11,AWSD                                                  53190000
         LR    10,11                                                    53280000
         SR    1,1                                                      53370000
ACST9    ST    1,ACNO              FIRST NO IGNORED IS STARTING POINT   53460000
ACST13   MVC   ACFIG,ACM1                                               53550000
         L     1,AWS1                                                   53640000
         LA    1,8(1)                                                   53730000
         ST    1,ACWSPT                                                 53820000
         L     4,ACTSZ             BUILD MAN ENTRIES FROM TOP DOWN      53910000
         LA    1,MANENTL(4)        TABLE INITIALLY EMPTY                54000000
         ST    1,ACTBL                                                  54090000
         SR    1,1                                                      54180000
ACST8    ST    1,DIRNO                                                  54270000
         ICALL DIRREAD             BRING IN NEXT DIRECTORY              54360000
         L     0,ACNO                                                   54450000
         L     5,ACTDIV                                                 54540000
         LA    5,1(5)              GUARANTEE POSITIVE                   54630000
         B     ACST1               LOAD UP TO (R5)-1 ENTRIES FROM THIS  54720000
*                                  DIRECTORY INTO ACTBL                 54810000
ACST2    ST    4,ACTBL             NEW BOTTOM OF MAN TABLE              54900000
         MVC   0(MANENTL,4),PERLIB MOVE THIS MAN INTO TABLE             54990000
         L     1,ACWSPT            MOVE HIS WSS INTO WS1 AREA           55080000
         LR    6,1                                                      55170000
         S     6,AWS1                                                   55260000
         CLC   LIBLINK-PERLIB(4,4),ZEROA    ANY WORKSPACES SAVED Q      55350000
         MVC   LIBLINK-PERLIB(4,4),ZEROA                                55440000
         BE    ACST12              NO.                                  55530000
         ST    6,LIBLINK-PERLIB(4) YES. POINT PERLIB AT WS1 AREA        55620000
ACST10   LA    3,PSWL(1)           CHECK FOR MAN, PERSAVW TABLE OVERLAP 55710000
         C     3,ACTBL                                                  55800000
         BL    ACST11                                                   55890000
         L     0,DIRNO             NOT ENOUGH SPACE.  DECREASE THE      55980000
         LTR   1,0                 NUMBER OF EXTRACTIONS PER DIRECTORY  56070000
         BNZ   *+8                 IN PROPORTION TO THE NUMBER OF       56160000
         LA    0,1                 DIRECTORIES NOT PROCESSED IN THIS    56250000
         SRDA  0,1                 PASS.                                56340000
         D     0,MANHASH           NOTE MIDPOINT SCALING                56430000
         M     0,ACTDIV                                                 56520000
         SLDA  0,1                                                      56610000
         ST    0,ACTDIV                                                 56700000
         B     ACST13                                                   56790000
ACST11   CLC   PSLINK-PERSAVW(4,2),ZEROA ANY MORE PERSAVWS TO BE MOVED  56880000
         BE    ACST12              NO. LINK IS ZERO.                    56970000
         L     2,PSLINK-PERSAVW(2)                                      57060000
         AR    2,MR                                                     57150000
         MVC   0(PSWL,1),0(2)                                           57240000
         LA    1,PSWL(1)           ADVANCE WS1 AREA POINTER             57330000
         ST    1,ACWSPT                                                 57420000
         B     ACST10                                                   57510000
ACST12   S     4,=A(MANENTL)       ADVANCE MAN TABLE POINTER            57600000
ACST1    L     1,MANSTAR                                                57690000
         AR    1,11                ABSOLUTE                             57780000
         LA    2,PERLIB-LIBNUM+ACM1                                     57870000
*                                  POINT R2 AT MAN NO. INFINITY (OR -1) 57960000
ACST5    CLC   LIBNUM-PERLIB(,1),ACM1                                   58050000
         BE    ACST3               IF THIS IS NOT END MARKER (-1),      58140000
*                                  ACCEPT MAN ONLY IF REJECTED ON LAST  58230000
*                                  PASS AND SMALLER THAN SMALLEST NO    58320000
*                                  SO FAR ON THIS PASS.                 58410000
         C     0,LIBNUM-PERLIB(1)  NOTE -1 COMPARES LOW                 58500000
         BNL   ACST4                                                    58590000
         CLC   LIBNUM-PERLIB(,1),LIBNUM                                 58680000
         BH    ACST4               NOTE -1 COMPARES HIGH                58770000
         LR    2,1                                                      58860000
ACST4    LA    1,MANENTL(1)                                             58950000
         B     ACST5                                                    59040000
ACST3    L     0,LIBNUM                                                 59130000
         CL    0,ACM1              IF NO ENTRIES,                       59220000
         BE    ACST6               LOOK NO FARTHER.                     59310000
         BCT   5,ACST2             ENTER 1/MANHASH OF THE ENTRIES       59400000
ACST6    CL    0,ACFIG             ACFIG IS LOWEST NO. REJECTED THIS    59490000
         BH    ACST7               PASS (-1 IS HIGH)                    59580000
         ST    0,ACFIG                                                  59670000
ACST7    L     1,DIRNO                                                  59760000
         LA    1,1(1)              ADVANCE DIRECTORY NUMBER             59850000
         C     1,MANHASH                                                59940000
         BL    ACST8                                                    60030000
         DROP  2                                                        60120000
ACC5     L     8,ACTBL                                                  60210000
         USING PERLIB,8                                                 60300000
         LR    7,8                                                      60390000
         L     1,ACNO              PREVIOUS MAN NUMBER PROCESSED        60480000
         L     2,=F'-1'            INFINITY                             60570000
ACC6     L     3,LIBNUM            SEARCH TABLE FOR MAN NUMBER NEXT LAR 60660000
         C     8,ACTSZ             GER THAN THE ONE PREVIOUSLY PRINTED. 60750000
         BH    ACC0                                                     60840000
         CLR   1,3                                                      60930000
         BNL   ACC7                                                     61020000
         CLR   2,3                                                      61110000
         BL    ACC7                                                     61200000
         LR    2,3                                                      61290000
         LR    7,8                                                      61380000
ACC7     LA    8,MANENTL(8)                                             61470000
         B     ACC6                                                     61560000
ACC0     MVC   ACLINE,ACPAT                                             61650000
         LR    8,7                                                      61740000
         L     1,ACFIG                                                  61830000
         CLR   2,1                                                      61920000
         BL    ACC4                NUMBER FOUND, LESS THAN LIMIT        62010000
         CL    1,ACM1              EQUAL OR PAST LIMIT.  IS LIMIT (1ST  62100000
         BE    ACC8                NO. IGNORED) -1 --  IF SO, SUMMARIZE 62190000
         BCT   1,ACST9             OTHERWISE, TAKE ANOTHER PASS         62280000
ACC4     ST    2,ACNO              SAVE NUMBER BEING PRINTED            62370000
         CLI   PARAMS+3,2          IF LISTING OF ONLY A SELECTED DIR    62460000
         BL    ACC3                WAS REQUESTED, MAKE SURE THIS USER   62550000
         SR    0,0                 BELONGS IN THAT DIRECTORY.           62640000
         LR    1,2                                                      62730000
         D     0,MANHASH                                                62820000
         C     0,PARAMS+8                                               62910000
         BNE   ACC5                                                     63000000
ACC3     CVD   2,ATEMP                                                  63090000
         EDMK  ACMAN,ATEMP+2                                            63180000
         CL    2,=F'1000'          PUBLIC OR PRIVATE --                 63270000
         BNL   ACC1A                                                    63360000
         MVC   ACCON(L'ACCON+L'ACCOM),ACCON-1 YES.  ERASE ACCOUNTING.   63450000
         B     ACC1B                                                    63540000
ACC1A    SR    1,1                                                      63630000
         IC    1,HISNAME                                                63720000
         TM    PLMISC,LIBLOCK      IF USER IS CURRENTLY LOCKED OUT,     63810000
         BZ    *+8                                                      63900000
         MVI   ACNAME-1,C'*'       NOTE EXCLUSION BY AN ASTERISK        63990000
         BCTR  1,0                                                      64080000
         CL    1,=F'11'            MOVE MAX 11 CHARS                    64170000
         BL    *+8                                                      64260000
         LA    1,10                                                     64350000
         EX    1,ACMV                                                   64440000
         L     2,=A(ZTOV)                                               64530000
         EX    1,ACTR                                                   64620000
         L     1,CUMCON                                                 64710000
         AL    1,TCUMCON+4                                              64800000
         ST    1,TCUMCON+4                                              64890000
         BC    12,ACC1                                                  64980000
         L     1,TCUMCON                                                65070000
         LA    1,1(1)                                                   65160000
         ST    1,TCUMCON                                                65250000
ACC1     L     1,CUMCON                                                 65340000
         LA    2,ACCON                                                  65430000
         BAL   15,ACRC                                                  65520000
         L     1,CUMCOM                                                 65610000
         AL    1,TCUMCOM+4                                              65700000
         ST    1,TCUMCOM+4                                              65790000
         BC    12,ACC2                                                  65880000
         L     1,TCUMCOM                                                65970000
         LA    1,1(1)                                                   66060000
         ST    1,TCUMCOM                                                66150000
ACC2     L     1,CUMCOM                                                 66240000
         LA    2,ACCOM                                                  66330000
         BAL   15,ACRC                                                  66420000
         LA    0,1                 BUMP THE COUNT OF USERS              66510000
         A     0,TACCT                                                  66600000
         ST    0,TACCT                                                  66690000
ACC1B    L     3,LIBLINK                                                66780000
         LR    2,3                                                      66870000
         A     3,AWS1                                                   66960000
         SR    0,0                                                      67050000
         SR    1,1                                                      67140000
ACCW2    LTR   2,2                                                      67230000
         BZ    ACCW1               END OF PERSAVW'S                     67320000
         LA    1,1(1)              WS COUNT                             67410000
         MVC   ACW1+3(1),PSLEN-PERSAVW(3)                               67500000
         A     0,ACW1              TRACK COUNT                          67590000
         CLC   PSNAME-PERSAVW(9,3),QZCONT                               67680000
         BNE   *+10                ATTACH '+1' TO WS COUNT IF CONTINUE  67770000
         MVC   ACWSCONT,=C'+1'     EXISTS. MANWSA DOESN'T INCLUDE IT.   67860000
         L     2,PSLINK-PERSAVW(3)                                      67950000
         LA    3,PSWL(3)           BUMP TO NEXT PERSAVW                 68040000
         B     ACCW2                                                    68130000
ACCW1    L     2,TWSS                                                   68220000
         AR    2,1                                                      68310000
         ST    2,TWSS              CUMULATIVE WORKSPACES                68400000
         LH    1,MANWSA                                                 68490000
         CVD   1,ATEMP                                                  68580000
         EDMK  ACWSS,ATEMP+5                                            68670000
         L     2,TTRK                                                   68760000
         AR    2,0                                                      68850000
         ST    2,TTRK                                                   68940000
         LH    3,MANWSQ            QUOTA                                69030000
         CVD   3,ATEMP                                                  69120000
         EDMK  ACQUOT,ATEMP+5                                           69210000
         CLC   ACNO,=F'1000'                                            69300000
         BH    ACCW3                                                    69390000
         CLI   PARAMS+7,0                                               69480000
         BE    ACC5                                                     69570000
         MVC   ACWSS,=CL7' '                                            69660000
         MVC   ACQUOT,=CL7' '                                           69750000
         SR    3,3                                                      69840000
ACCW3    CVD   0,ATEMP                                                  69930000
         EDMK  ACTRK,ATEMP+4                                            70020000
         A     3,TQUOT                                                  70110000
         ST    3,TQUOT                                                  70200000
         ICALL OUTWRT                                                   70290000
         DC    AL4(ACLINE)                                              70380000
         CLI   PARAMS+7,0          PRINTING WSNAMES --                  70470000
         BE    ACC5                NO.                                  70560000
         L     3,LIBLINK           YES.                                 70650000
         LTR   3,3                 ANY SAVED WORKSPACES --              70740000
         BZ    ACCP5               NO.                                  70830000
         A     3,AWS1                                                   70920000
ACA2     MVI   ACLINE,C' '                                              71010000
         MVC   ACLINE+1(L'ACLINE-1),ACLINE                              71100000
         SR    2,2                                                      71190000
         IC    2,PSNAME-PERSAVW(3)                                      71280000
         BCTR  2,0                                                      71370000
         CL    2,=F'11'                                                 71460000
         BL    *+8                 MOVE MAX 11 CHARS                    71550000
         LA    2,10                                                     71640000
         EX    2,ACAMV                                                  71730000
         L     1,=A(ZTOV)                                               71820000
         EX    2,ACATR                                                  71910000
         L     2,PSMAN-PERSAVW(3)                                       72000000
         CL    2,ACNO                                                   72090000
         BE    ACA1                                                     72180000
         CVD   2,ATEMP                                                  72270000
         MVC   ACAMPAT,ACPAT                                            72360000
         EDMK  ACAMPAT,ATEMP+2                                          72450000
ACA1     LH    1,PSFILE-PERSAVW(3)                                      72540000
         SR    0,0                 SCALE TO FILE NUMBER TO BE USEFUL    72630000
         D     0,=A(CDCL)                                               72720000
         MVC   ACDISK,ACDKPAT      MOVE IN PATTERN                 DASD 72810000
         STC   1,ACDFILE           FILE NUMBER                          72900000
         L     1,PSCYL-PERSAVW(3)                                  DASD 72990000
         STC   1,ACDTRK            TRACK NUMBER                         73080000
         SRL   1,16                                                     73170000
         STH   1,ACDCYL            CYLINDER NUMBER                 DASD 73260000
         IC    1,PSLEN-PERSAVW(3)                                  DASD 73350000
         STC   1,ACDLNGTH          WS LENGTH IN TRACKS                  73440000
         ICALL OUTWRT                                                   73530000
         DC    AL4(ACLINE)                                              73620000
         CLC   PSLINK-PERSAVW(4,3),ZEROA  TEST FOR END OF LIST          73710000
         LA    3,PSWL(3)           ADVANCE TO NEXT PERSAVW              73800000
         BNE   ACA2                PRINT IT IF IT EXISTS                73890000
ACCP5    ICALL OUTWRT              PRINT A BLANK LINE BETWEEN USERS     73980000
         DC    AL4(ACJFUA)                                              74070000
         B     ACC5                                                     74160000
ACC8     MVC   ACMAN,FUASRL                                             74250000
         LM    0,1,TCUMCON         PRINT TOTAL CONNECTED, COMPUTE       74340000
         LA    2,ACCON                                                  74430000
         BAL   15,ACRC+2                                                74520000
         LM    0,1,TCUMCOM                                              74610000
         LA    2,ACCOM                                                  74700000
         BAL   15,ACRC+2                                                74790000
         L     1,TACCT             TOTAL NUMBER OF USERS                74880000
         CVD   1,ATEMP                                                  74970000
         EDMK  ACMAN+6(6),ATEMP+5                                       75060000
         L     1,TWSS                                                   75150000
         CVD   1,ATEMP             TOTAL WORKSPACES                     75240000
         EDMK  ACWSS,ATEMP+5                                            75330000
         L     1,TTRK                                                   75420000
         CVD   1,ATEMP                                                  75510000
         EDMK  ACTRK,ATEMP+4       TOTAL TRACKS                         75600000
         L     1,TQUOT                                                  75690000
         CVD   1,ATEMP                                                  75780000
         EDMK  ACQUOT,ATEMP+5      TOTAL QUOTATA                        75870000
         ICALL OUTWRT                                                   75960000
         DC    AL4(ACJFUA)                                              76050000
         ICALL OUTWRT                                                   76140000
         DC    AL4(ACLINE)                                              76230000
         ICALL OUTWRT              PRINT REMAINING-SPACE INFORMATION    76320000
         DC    AL4(ACDHD)          FOR EACH DIRECTORY                   76410000
         SR    5,5                                                      76500000
ACD1     LR    1,5                 NEXT DIRECTORY NUMBER                76590000
         ICALL DIRREAD                                                  76680000
         MVC   ACLINE(L'ACDPAT),ACDPAT                                  76770000
         CVD   5,ATEMP                                                  76860000
         EDMK  ACDIRNO-ACDPAT+ACLINE,ATEMP+6 DIRECTORY NUMBER           76950000
         L     1,DSNXTF            FIRST CALCULATE SPACE REQUIRED BY    77040000
         LA    0,FIRSTENT-M                                             77130000
         SR    1,0                 THE 'TYPICAL USER'                   77220000
         LR    LKR,1               AS TOTAL PERSAVW SPACE / MAN ENTRIES 77310000
         SR    0,0                                                      77400000
         D     0,=A(PSWL)                                               77490000
         CVD   1,ATEMP                                                  77580000
         EDMK  ACNWSS-ACDPAT+ACLINE,ATEMP+5  WSS NOW IN USE             77670000
         LR    1,LKR                                                    77760000
         L     3,PARREL                                                 77850000
         L     3,PARREL            AS TOTAL PERSAVW SPACE / MAN ENTRIES 77940000
         S     3,MANSTAR                                                78030000
         LA    4,MANENTL           PLUS MANENTL                         78120000
         MR    0,4                                                      78210000
         DR    0,3                                                      78300000
         SR    2,2                                                      78390000
         DR    2,4                 R3 IS NO. OF PERLIBS                 78480000
         AR    4,1                 NOW R4 IS TYPICAL SPACE REQUIREMENT  78570000
         CVD   3,ATEMP                                                  78660000
         EDMK  ACNUS-ACDPAT+ACLINE,ATEMP+5                              78750000
         L     3,MANSTAR                                                78840000
         S     3,DSNXTF            ACTUAL REMAINING SPACE IN DIRECTORY  78930000
         LR    0,3                                                      79020000
         SR    2,2                 FIND HOW MANY ADDITIONAL TYPICAL     79110000
         DR    2,4                 USERS WE COULD FIT HERE              79200000
         CVD   3,ATEMP                                                  79290000
         EDMK  ACDUS-ACDPAT+ACLINE,ATEMP+5                              79380000
         SRDA  0,32                SAME CALCULATION FOR ADDITIONAL      79470000
         D     0,=A(PSWL)          WORKSPACES BUT NO MORE USERS         79560000
         CVD   1,ATEMP                                                  79650000
         EDMK  ACDWS-ACDPAT+ACLINE,ATEMP+5                              79740000
         L     8,MANSTAR           REPEAT THESE CALCULATIONS,           79830000
*                                  ASSUMING THAT SPACE MUST BE RESERVED 79920000
*                                  FOR ALL WS QUOTA NOT IN USE.         80010000
         SR    3,3                                                      80100000
ACD2     L     1,LIBNUM-PERLIB(8,MR)                                    80190000
         LTR   1,1                 END OF PERLIBS                       80280000
         BM    ACD5A                                                    80370000
         C     1,=F'1000'                                               80460000
         BNH   ACD5                                                     80550000
         AH    3,MANWSQ-PERLIB(8,MR)                                    80640000
         SH    3,MANWSA-PERLIB(8,MR)  QUOTA MINUS ACTUAL                80730000
         L     9,LIBLINK-PERLIB(8,MR)                                   80820000
         BXLE  9,MR,ACD5           LOOK FOR ABSENCE OF CONTINUE         80910000
ACD6     CLC   PSNAME-PERSAVW(9,9),QZCONT                               81000000
         BE    ACD5                                                     81090000
         L     9,PSLINK-PERSAVW(9)                                      81180000
         BXH   9,MR,ACD6                                                81270000
         LA    3,1(3)                                                   81360000
ACD5     LA    8,MANENTL(8)                                             81450000
         B     ACD2                                                     81540000
ACD5A    M     2,=A(0-PSWL)                                             81630000
         A     3,MANSTAR                                                81720000
         S     3,DSNXTF            R3 = UNBOOKED SPACE (MAYBE NEGATIVE) 81810000
         LR    0,3                 WE'LL NEED IT LATER                  81900000
         M     2,=F'1'                                                  81990000
         DR    2,4                                                      82080000
         CVD   3,ATEMP             EXTRA USERS TO ADD                   82170000
         LA    1,OBDUS+L'OBDUS-1-ACDPAT+ACLINE                          82260000
         EDMK  OBDUS-ACDPAT+ACLINE,ATEMP+5                              82350000
         BNM   ACD3                                                     82440000
         BCTR  1,0                                                      82530000
         MVI   0(1),C'-'                                                82620000
ACD3     SRDA  0,32                SEE THE DIFFERENT TECHNIQUES         82710000
         D     0,=A(PSWL)          ADDITIONAL WORKSPACES                82800000
         CVD   1,ATEMP                                                  82890000
         LA    1,OBDWS+L'OBDWS-1-ACDPAT+ACLINE                          82980000
         EDMK  OBDWS-ACDPAT+ACLINE,ATEMP+5                              83070000
         BNM   ACD4                ALSO POSSIBLY NEGATIVE               83160000
         BCTR  1,0                                                      83250000
         MVI   0(1),C'-'                                                83340000
ACD4     ICALL OUTWRT                                                   83430000
         DC    AL4(ACLINE)                                              83520000
         LA    5,1(5)              ADVANCE DIRECTORY NUMBER             83610000
         C     5,MANHASH                                                83700000
         BL    ACD1                                                     83790000
         ICALL OUTWRT                                                   83880000
         DC    AL4(ACHDND)         PAGE SKIP, NO HEADING                83970000
         IRETURN                                                        84060000
ACMV     MVC   ACNAME(0),HISNAME+1                                      84150000
ACTR     TR    ACNAME(0),0(2)      ZTOV                                 84240000
ACRC     SR    0,0                                                      84330000
         AL    1,=F'150'                                                84420000
         BC    12,*+8              ROUND UP IN DOUBLE PRECISION         84510000
         A     0,=F'1'                                                  84600000
         D     0,=F'300'           CONVERT TIME FROM 300THS OF SECS     84690000
         SR    0,0                 TO DECIMAL HOURS , MINS, SECS        84780000
         D     0,=F'60'                                                 84870000
         LR    4,0                                                      84960000
         SR    0,0                                                      85050000
         D     0,=F'60'                                                 85140000
         LR    3,0                                                      85230000
         M     0,=F'100'                                                85320000
         AR    1,3                                                      85410000
         M     0,=F'100'                                                85500000
         AR    1,4                                                      85590000
         CVD   1,ATEMP                                                  85680000
         EDMK  0(L'ACCON,2),ATEMP+3                                     85770000
         BR    15                                                       85860000
ACHD     DC    C'       ACCOUNT NO.    NAME       CONNECT TIME      CPU.85950000
                TIME    WSS     TRACKS  QUOTA     '                     86040000
ACHDND   DC    X'14FE'             PAGE HEADING END TEXT                86130000
ACDHD    DC    C'DIRECTORY NO.   LIBS, WSS --   CURRENT      IN REMAINI.86220000
               NG SPACE      IN UNBOOKED SPACE',X'14FE'                 86310000
ACDPAT   DS    0CL(L'ACDHD+1)                                           86400000
ACDIRNO  DC    X'40404040202120'                                        86490000
         DC    CL19' '                                                  86580000
ACNUS    DC    X'402020202120'                                          86670000
ACNWSS   DC    X'402020202120'                                          86760000
         DC    CL10' '                                                  86850000
ACDUS    DC    X'402020202120'                                          86940000
ACDWS    DC    X'402020202120'                                          87030000
         DC    CL12' '                                                  87120000
OBDUS    DC    X'402020202120'                                          87210000
OBDWS    DC    X'402020202120'                                          87300000
         DC    X'FF'                                                    87390000
FUASRL   DC    C' TOTAL ',X'2020202120'                                 87480000
         DS    0H                                                  DASD 87570000
ACDKPAT  DC    C'LIB '                                             DASD 87660000
         DC    X'120040'           FILE NUMBER                     DASD 87750000
         DC    C'CYL '                                             DASD 87840000
         DC    X'10'                                               DASD 87930000
         DC    2H'0'               CYLINDER NUMBER                 DASD 88020000
         DC    C' TRK '                                            DASD 88110000
         DC    X'120040'           TRACK NUMBER                    DASD 88200000
         DC    C'LEN '                                             DASD 88290000
         DC    X'120040FF'         WS LENGTH IN TRACKS             DASD 88380000
ACDZ     EQU   *                                                   DASD 88470000
ACPAT    DC    X'404040404040402020202020202020202020'                  88560000
         DC    X'40404040404040404040404040'                            88650000
ACTIMPAT DC    X'40404020202021204B20204B2020'                          88740000
         DC    X'40404020202021204B20204B2020'                          88830000
         DC    X'40402020202120'                                        88920000
         DC    X'4040'                                                  89010000
         DC    X'4020202020202120'                                      89100000
         DC    X'40402020202120'   QUOTA                                89190000
         DC    X'FF'                                                    89280000
ACLINE   DS    0CL(L'ACDHD)                                             89370000
         DS    6C                                                       89460000
ACMAN    DS    CL12                                                     89550000
         DS    2C                                                       89640000
ACNAME   DS    CL11                                                     89730000
ACCON    DS    CL14                                                     89820000
ACCOM    DS    CL14                                                     89910000
ACWSS    DS    CL7                                                      90000000
ACWSCONT DS    CL2                                                      90090000
ACTRK    DS    CL8                                                      90180000
ACQUOT   DS    CL7                                                      90270000
         ORG   ACLINE                                                   90360000
         DS    CL7                                                      90450000
ACAMPAT  DS    CL18                                                     90540000
         DS    CL2                                                      90630000
ACWNAME  DS    CL11                                                     90720000
         DS    CL5                                                      90810000
         DS    0H                                                  DASD 90900000
ACDISK   DS    CL(ACDZ-ACDKPAT)                                    DASD 90990000
ACDFILE  EQU   ACDISK+5            FILE NUMBER                     DASD 91080000
ACDCYL   EQU   ACDISK+14           CYLINDER NUMBER                 DASD 91170000
ACDTRK   EQU   ACDISK+22           TRACK NUMBER                    DASD 91260000
ACDLNGTH EQU   ACDISK+29           WS LENGTH IN TRACKS             DASD 91350000
         ORG   ACLINE+L'ACDHD+1                                         91440000
ACJFUA   DC    X'FF'                                                    91530000
ACAMV    MVC   ACWNAME(0),PSNAME+1-PERSAVW(3)                           91620000
ACATR    TR    ACWNAME(0),0(1)     ZTOV                                 91710000
QZCONT   DC    AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE)                           91800000
ACM1     DC    F'-1'                                                    91890000
ACFIG    DS    F                   NO. OF FIRST IGNORED MAN, THIS PASS  91980000
DIRNO    DS    F                   DIRECTORY PRESENTLY IN CORE          92070000
ACWSPT   DS    A                   NEXT ENTRY, PERSAVW'S FOR MEN IN ACT 92160000
*                                  BL                                   92250000
TCUMCON  DS    2F                                                       92340000
TCUMCOM  DS    2F                                                       92430000
ACNO     DS    F                   NO. OF THIS MAN (OR 1ST IGNORED      92520000
*                                  MAN, THIS PASS)                      92610000
TWSS     DS    F                                                        92700000
TTRK     DS    F                                                        92790000
TACCT    DS    F                                                        92880000
TQUOT    DS    F                                                        92970000
ACW1     DC    F'0'                                                     93060000
ATEMP    DC    D'0'                                                     93150000
ZEROA    DC    F'0'                                                     93240000
ACTSZ    DC    A(0)                                                     93330000
ACTBL    DC    F'0'                BASE OF EXTRACTED MAN ENTRY TABLE    93420000
ACTDIV   DC    F'0'                NO. OF MAN ENTRIES TO EXTRACT        93510000
*                                  FROM EACH DIR                        93600000
         DROP  8                                                        93690000
         DROP  11                                                       93780000
MANHASH  DC    F'0'                                                     93870000
         LTORG                                                          93960000
         ENTRY WSLOC                                                    94050000
WSLOC    DC    A(WSD,0,0)                                               94140000
AWSD     EQU   WSLOC                                                    94230000
AWS1     EQU   WSLOC+4                                                  94320000
AWS2     EQU   WSLOC+8                                                  94410000
WLEN     DC    A(*-*)              WSLEN                                94500000
ACTWL    EQU   WLEN                                                     94590000
PARAMS   DC    20F'0'                                                   94680000
WSD      DS    0D                                                       94770000
************** MAIN  MUST BE LAST DECK IN LINK MODULE ****************  94860000
         TITLE 'U S E F U L   D S E C T S'                              94950000
         COPY  CDCPARS                                                  95040000
         COPY  DIRSECT                                                  95130000
         END   MAIN                                                     95220000
./  ADD    NAME=APLURSTR
RSTR     TITLE 'APL UTILITY RESTORE FUNCTIONS                 05/11/70' 00100000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970, 1971            00200000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00300000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00400000
*                                                                       00800000
         EXTRN ADPAR                                                    00900000
         EXTRN CCREJ                                                    01000000
         EXTRN CDCBASE                                                  01100000
         EXTRN CDCBXLE                                                  01200000
         EXTRN DIRWRT                                                   01300000
         EXTRN DIRREAD                                                  01400000
         EXTRN DIRTAB                                                   01500000
         EXTRN DISKFMT                                                  01600000
         EXTRN DWR                                                      01700000
         EXTRN DWRZ                                                     02200000
         EXTRN KMANHASH                                                 02300000
         EXTRN LCYLOG                                                   02400000
         EXTRN MTFLAGS                                                  02500000
         EXTRN MTRD                                                     02600000
         EXTRN MTRDZ                                                    02700000
         EXTRN MTROPEN                                                  02800000
         EXTRN MTRCLOSE                                                 02900000
         EXTRN OUTWRT                                                   03000000
         EXTRN OUTWRTL                                                  03100000
         EXTRN SELCARD                                                  03200000
         EXTRN UTDATE                                                   03300000
         EXTRN UTFLAGS                                                  03400000
         EXTRN VTOZ                                                     03500000
         EXTRN WSLEN                                                    03600000
         EXTRN WSLOC                                                    03700000
         PRINT OFF                 COPY APLDEFN ZSYMBOLS                03800000
         COPY APLDEFN                                                   03900000
         COPY  ZSYMBOLS                                                 04000000
         TITLE 'LIBRARY TABLE SEARCH SUBROUTINE'                        04100000
         PRINT ON,NOGEN                                                 04200000
RSTRSECT CSECT                                                          04300000
*                                                                       04400000
*        FIND ENTRY IN MAN TABLE FOR NUMBER IN R0.                      04500000
*        RETURNS ABS ADDRESS IN R1                                      04600000
*        WITH R0 UNCHANGED                                              04700000
         DROP 11                                                        04800000
         USING M,10                                                     04900000
LOC8MAN  PROLOG                                                         05000000
         ENTRY LOC8MAN                                                  05100000
         L     1,MANSTAR                                                05200000
LOC8A    AR    1,10                                                     05300000
LOC8C    C     0,0(1)                                                   05400000
         BE    LOC8B                                                    05500000
         CLC   0(4,1),=F'-1'                                            05600000
         LA    1,MANENTL(1)                                             05700000
         BNE   LOC8C                                                    05800000
         IRETURN                   NOT FOUND EXIT                       05900000
LOC8B    LM    12,15,0(13)                                              06000000
         B     4(15)               FOUND EXIT                           06100000
         DROP  10                                                       06200000
         TITLE 'APL UTILITY LIBRARY RESTORE'                            06300000
*                                                                       06400000
*                                                                       06500000
*        RESTORE LIBRARY TO DISK FROM SYS004, SYS005 MAG TAPE           06600000
*                                                                       06700000
MTEOF    EQU   X'10'                                                    06800000
MTREJ    EQU   X'04'                                                    06900000
UTWSLST  EQU   X'80'               UTFLAGS MASK - WSLIST                07000000
UT3WSS   EQU   X'40'               UTFLAGS MASK - DOUBLE BUFFERING      07100000
         USING M,10                                                     07200000
*        RESTORE STARTS OUT BY CHECKING FULL-DUMP VS INCREMENTAL-DUMP   07300000
*        TIMES GIVEN BY THE FIRST TAPE DIRECTORY.  IF THEY ARE EQUAL,   07400000
*        THE TAPE IS A FULL-DUMP TAPE AND RESTORE TAKES PLACE IN ONE    07500000
*        PASS.  OTHERWISE TAPE MUST HAVE BEEN WRITTEN BY INCDUMP.  THE  07600000
*        INCREMENTAL RESTORE TAKES TWO PASSES.  THE FIRST PASS READS AN 07700000
*        INCREMENTAL-DUMP TAPE, WRITES DIRECTORIES TO DISK AFTER ERAS-  07800000
*        ING PSLEN, PSCYL FROM PERSAVW AND MANWSA FROM PERLIB, AND THEN 07900000
*        FUNCTIONS LIKE A FULL RESTORE.  WSSAVE SUBROUTINE DOES NOT     08000000
*        NEED TO CREATE PERSAVWS, SINCE THEY ALREADY EXIST, BUT IT DOES 08100000
*        GET FREE DISK SPACE.  AT THE END OF THE FIRST PASS THE LIBRARY 08200000
*        HAS BEEN RESTORED, EXCEPT FOR WORKSPACES SAVED BEFORE THE FULL 08300000
*        DUMP WHICH PRECEDED THE INCREMENTAL DUMP.                      08400000
*        ON THE SECOND PASS, THE TAPE DIRECTORIES ARE IGNORED (EXCEPT   08500000
*        TO CHECK FULL- VS INCREMENTAL-DUMP DATES), AND WORKSPACES ARE  08600000
*        READ FROM TAPE.  FOR EACH WORKSPACE WHERE NO PERLIB EXISTS,    08700000
*        ONE OF THREE SITUATIONS EXSISTS.                               08800000
*              1)  A PERSAVW EXISTS AND PSLEN, PSCYL ARE ZERO.  THIS    08900000
*                  WORKSPACE EXISTED AT THE TIME OF THE INCDUMP, BUT    09000000
*                  HAD NOT BEEN SAVED RECENTLY.  FILL IN THE PERSAVW    09100000
*                  AND WRITE THE WORKSPACE TO DISK.                     09200000
*              2)  A PERSAVW EXISTS AND PSLEN, PSCYL ARE NONZERO.  THIS 09300000
*                  WORKSPACE HAD BEEN SAVED BETWEEN THE FULL DUMP       09400000
*                  AND THE INCREMENTAL DUMP, AND A NEWER VERSION IS     09500000
*                  ALREADY ON DISK.  IGNORE THIS WORKSPACE.             09600000
*              3)  NO PERSAVW EXISTS.  THIS WORKSPACE WAS DROPPED BE-   09700000
*                  TWEEN THE FULL DUMP AND THE INCREMENTAL DUMP. IG-    09800000
*                  NORE THIS WORKSPACE.                                 09900000
*        FOR EACH WORKSPACE WHERE NO PERLIB EXISTS, THE LIBRARY WAS     10000000
*        DELETED BETWEEN THE FULL DUMP AND THE INCREMENTAL DUMP.        10100000
*        IGNORE THIS WORKSPACE.                                         10200000
*        AT THE END OF THE SECOND PASS THE LIBRARY HAS BEEN RESTORED    10300000
*        TO THE TIME OF THE INCREMENTAL DUMP.                           10400000
*                                                                       10500000
DREST    PROLOG                                                         10600000
         ENTRY DREST                                                    10700000
         MVI   RTFLG,0             ORDINARY FULL RESTORE                10800000
*              REENTRY FOR INCREMENTAL RESTORE, PASS 2                  10900000
RESCOM2  ICALL MTROPEN             OPEN TAPE INPUT FILE                 11000000
         ICALL SETCON                                                   11100000
         L     9,HASHVAL                                                11200000
         L     11,DIRWS                                                 11300000
DRRDIR   ST    9,DIRCT                                                  11400000
DRRDIR2  ICALL MTRD                READ NEXT DIRECTORY                  11500000
         ICALL MTRDZ                                                    11600000
         L     1,=A(MTFLAGS)                                            11700000
         TM    0(1),MTREJ          ACCEPT REJECTED READ QUIETLY --      11800000
         BO    DRRDIR2             LATER CHECKS WILL TAKE CARE OF IT    11900000
         LA    2,RFTAPE            DIFFERENT MESSAGES FOR DIFF CASES    12000000
         CLI   RTFLG,2             FULL REST, INC REST PASS 1 SAY       12100000
         BNH   *+8                 'INCORRECT NUMBER OF DIRECTORIES'    12200000
         LA    2,IRCE              INC REST-2 SAYS 'NOT A FULL-DUMP'    12300000
         TM    0(1),MTEOF                                               12400000
         BCR   1,2  BO             MIGHTY SHORT DUMP TAPE               12500000
         LR    10,11                                                    12600000
         CLC   WFLNAME(12),DIRTNAME                                     12700000
         BCR   7,2                 NOT A DIRECTORY AT ALL               12800000
         TM    CREATING,1                                               12900000
         BNZ   DRCRT               CREATE HANDLES DIRECTORIES ODDLY     13000000
         L     1,WFLMAN                                                 13100000
         STH   1,DIRIN                                                  13200000
         ST    1,WFLLIB            AVOID HISTORICAL ACCIDENT OF         13300000
*                                  MEANINGLESS WFLLIB IN DIRECTORY      13400000
         A     1,DIRCT             CHECK DIRECTORY NUMBER               13500000
         C     1,HASHVAL                                                13600000
         BNE   RFTAPE                                                   13700000
         S     1,DIRCT             WE NEED TRUE DIRECTORY NUMBER        13800000
         MVC   VVMM(4),=C'V1M1'    DIR HAS V1,M1 FORMAT            C059 13900000
         MVC   NUMDIRS(4),HASHVAL  NO. DIRECTORIES                 C059 14000000
         XC    SALVHED(256),SALVHED ERASE SALVAGED-TRACK LISTS          14100000
         XC    SALVHED+256(FIRSTENT-SALVHED-256),SALVHED+256            14200000
         CLI   RTFLG,2             IF JUST STARTING A FULL RESTORE,     14300000
         BH    IRC                 (INCREMENTAL RESTORE, PASS 2)        14400000
*                                  CHECK DATES.  NOTE BECAUSE OF        14500000
*                                  FOLLOWING BXH, NO NEED TO CHECK      14600000
*                                  RTFLG=2. RTFLG=1 DOES NOT OCCUR HERE 14700000
         BXH   1,1,IRA             CHECK DATE ON DIRECTORY ZERO ONLY    14800000
         MVC   IRMSTS,DIDTS-M(10)  LOG TIME OF DUMP OR INCDUMP          14900000
         ICALL OUTWRTL                                                  15000000
         DC    AL4(IRMSG1)                                              15100000
         L     3,=A(CDCBXLE)       SET ALL CFREDSK'S TO EXTLOW          15200000
         LM    0,2,0(3)            NOT NECESSARY UNLESS SOME OTHER      15300000
         USING CDCPARS,2                                                15400000
DREST2   MVC   CFREDSK,EXTLOW      UTILITY OPERATION PRECEDED THIS ONE  15500000
         BXLE  2,0,DREST2                                               15600000
         L     2,8(3)              NEED EXT 0 AGAIN                     15700000
         L     1,HASHVAL           RESET EXTENT 0 CFREDSK               15800000
         SLA   1,3                 TO 1ST TRACK PAST LAST DIR           15900000
         A     1,=A(DIRTAB)                                             16000000
         MVC   CFREDSK,0(1)                                             16100000
         DROP  2                                                        16200000
         CLC   DFDTS(12),DIDTS     WHAT KIND OF TAPE IS THIS --         16300000
         BE    DRES2B              FULL-DUMP TAPE.  SINGLE-PASS RESTORE 16400000
         MVI   RTFLG,2             INC-DUMP TAPE.  THIS IS PASS 1 OF 2  16500000
*              INCREST PASS 1 -- USING INCREMENTAL-DUMP TAPE            16600000
         MVC   FDTS,DFDTS          SAVE TIME, DATE OF FULL DUMP FOR     16700000
*                                  LATER CHECK IN PASS 2                16800000
IRA      CLI   RTFLG,2                                                  16900000
         BL    DRES2B              ANOTHER CHECK FOR FULL-DUMP TAPES    17000000
         LA    1,FIRSTENT-M        PREPARE TO ZERO PSLEN,PSCYL          17100000
         SR    0,0                                                      17200000
IRB      C     1,DSNXTF            END OF PERSAVWS                      17300000
         BNL   IRG                                                      17400000
         ST    0,PSCYL-PERSAVW(1,10)                               DASD 17500000
         STC   0,PSLEN-PERSAVW(1,10)                               DASD 17600000
         LA    1,PSWL(1)           ADVANCE TO NEXT PERSAVW              17700000
         B     IRB                                                      17800000
IRG      L     1,MANSTAR           PREPARE TO ZERO EVERYONE'S SAVED     17900000
IRE      L     2,LIBNUM-PERLIB(1,10) WORKSPACE COUNT                    18000000
         CL    2,=F'-1'            STOPPER                              18100000
         BE    IRF                                                      18200000
         STH   0,MANWSA-PERLIB(1,10)                                    18300000
         LA    1,MANENTL(1)                                             18400000
         B     IRE                                                      18500000
*                                                                       18600000
*        INCREST PASS 2 -- USING FULL-DUMP TAPE                         18700000
IRC      BXH   1,1,IRH             CHECK ON DIRECTORY ZERO ONLY --      18800000
         CLC   DFDTS(12),DIDTS     FULL-DUMP TIMESTAMP WILL AGREE WITH  18900000
         BE    IRD                 INCDUMP TIMESTAMP IF IT IS TRULY A   19000000
*                                  FULL-DUMP TAPE                       19100000
IRCE     ICALL OUTWRTL                                                  19200000
         DC    AL4(IRMSG4)                                              19300000
         B     IRM                 GIVE HIM ANOTHER TRY WITH NEW TAPES  19400000
IRD      CLC   FDTS(12),DFDTS      FULL-DUMP DATE CONTROLLING THE       19500000
         BE    IRH                 INCDUMP TAPE CREATION MUST MATCH     19600000
         ICALL OUTWRTL             DATE ON THIS FULL-DUMP TAPE          19700000
         DC    AL4(IRMSG3)         (WHICH IT ASSUREDLY DOES NOT)        19800000
         B     IRM                                                      19900000
*                                                                       20000000
*        FULL RESTORE WITH SINGLE SET OF TAPES                          20100000
DRES2B   L     1,MANSTAR                                                20200000
         SR    0,0                 CLEAR ALL LINKS TO SAVED WORKSPACES  20300000
DRES3    L     2,LIBNUM-PERLIB(1,10) IN MAN AND COMMON LIB TABLE        20400000
         CL    2,=F'-1'                                                 20500000
         BE    DRES4                                                    20600000
         ST    0,LIBLINK-PERLIB(1,10)                                   20700000
         STH   0,MANWSA-PERLIB(1,10)                                    20800000
         LA    1,MANENTL(1)                                             20900000
         B     DRES3                                                    21000000
DRES4    LA    1,FIRSTENT-M                                             21100000
         ST    1,DSNXTF            ENTRIES                              21200000
IRF      LH    1,DIRIN                                                  21300000
         ICALL DIRWRT                                                   21400000
IRH      MVI   DIRIN+1,255         NO DIRECTORY IN CORE                 21500000
         L     9,DIRCT             ADVANCE TO NEXT DIRECTORY, IF ANY    21600000
         BCT   9,DRRDIR                                                 21700000
DRRDIRZ  EQU   *                                                        21800000
         DROP  10                                                       21900000
DRES1    L     11,CURWS            ALTERNATE CORE SPACES                22000000
         ICALL MTRD                READ IN NEXT WORKSPACE               22100000
         ICALL MTRDZ                                                    22200000
         L     1,=A(UTFLAGS)       IF DOUBLE BUFFERING IS IN EFFECT,    22300000
         TM    0(1),UT3WSS                                              22400000
         BZ    DRES1A                                                   22500000
         ICALL DWRZ                  DISK WRITE.                        23000000
DRES1A   L     1,=A(MTFLAGS)       CHECK FOR TAPE END-OF-FILE           23100000
         TM    0(1),MTEOF                                               23200000
         BO    DRES2               IT'S ON.  TAPE IS COPIED.            23300000
         TM    0(1),MTREJ                                               23400000
         BO    DRES1               BRANCH IF WS REJECTED BY MTREAD      23500000
         USING M,11                                                     23600000
         CLC   WFLNAME(12),DIRTNAME                                     23700000
         BE    DRNEWDIR            WE COULD FIND A DIRECTORY.           23800000
         L     1,WFLLIB                                                 23900000
         ICALL GETDIR                                                   24000000
         L     0,WFLLIB                                                 24100000
         ICALL LOC8MAN                                                  24200000
         B     DRNOMAN             NOT FOUND.                           24300000
         ICALL WSSAVE                                                   24400000
         DROP  11                                                       24500000
         L     1,=A(UTFLAGS)       IF DOUBLE BUFFERING IS IN EFFECT,    24600000
         TM    0(1),UT3WSS                                              24700000
         BZ    DRES1B                                                   24800000
         L     11,ALTWS            SWAP BUFFERS AND GO GET NEXT WS      24900000
         MVC   ALTWS(4),CURWS        FROM TAPE,                         25000000
         ST    11,CURWS                                                 25100000
         B     DRES1                                                    25200000
DRES1B   EQU   *                                                        25300000
         ICALL DWRZ                TO DISK, THEN GO GET NEXT WS         25800000
         B     DRES1               FROM TAPE.                           25900000
DRES2    CLI   DIRIN+1,255                                              26000000
         BE    DRESTZ                                                   26100000
         LH    1,DIRIN                                                  26200000
         ICALL DIRWRT                                                   26300000
DRESTZ   CLI   RTFLG,2             IF END OF INCREST PASS 1,            26400000
         BE    IRM                 THERE IS MORE TO DO.                 26500000
         BL    DRESTZ2             IF END OF INCREST PASS 2,            26600000
*                                  TAKE A FINAL PASS THROUGH THE        26700000
*                                  DIRECTORIES TO LOOK FOR LONELY       26800000
*                                  PERSAVWS WITH PSLEN=0 -- WE FOUND    26900000
*                                  NO WORKSPACE ON EITHER SET OF TAPES  27000000
         L     9,HASHVAL                                                27100000
IRC0     L     1,HASHVAL                                                27200000
         SR    1,9                 NEXT DIRECTORY NUMBER                27300000
         ICALL DIRREAD                                                  27400000
         USING M,10                                                     27500000
         USING PERLIB,4                                                 27600000
         USING PERSAVW,5                                                27700000
         L     4,MANSTAR                                                27800000
         AR    4,10                ABS PERLIB POINTER                   27900000
IRC6     CLC   LIBNUM(4),=F'-1'    LIB TABLE STOPPER                    28000000
         BE    IRC2                END OF DIRECTORY                     28100000
         L     5,LIBLINK           PTR TO FIRST (IF ANY) PERSAVW        28200000
         LA    6,0(4,10)           LAGGING PERSAVW POINTER              28300000
         LR    6,4                 LAGGING PERSAVW POINTER.             28400000
IRC4     LTR   5,5                                                      28500000
         BZ    IRC1                END OF PERSAVW CHAIN                 28600000
         AR    5,10                ABS PERSAVW POINTER                  28700000
         CLI   PSLEN,0             PSLEN NONZERO MEANS A WS IS REALLY   28800000
         BNZ   IRC3                SAVED ON DISK                        28900000
         MVC   IRCMWS(4),PSMAN     LOG MISSING WORKSPACE                29000000
         MVC   IRCMWS+4(12),PSNAME                                      29100000
         ICALL OUTWRTL                                                  29200000
         DC    AL4(IRCMS)                                               29300000
         MVC   PSLINK-PERSAVW(4,6),PSLINK  LINK AROUND THIS PERSAVW     29400000
*                                  PERWSAVW IS NOW IN LIMBO AND WILL    29500000
*                                  NOT BE RECLAIMED UNTIL THE NEXT      29600000
*                                  FULL DUMP AND RESTORE                29700000
         B     IRC5                                                     29800000
IRC3     LR    6,5                 GOOD PERSAVW.  ADVANCE LAGGING PTR   29900000
IRC5     L     5,PSLINK            ADVANCE PERSAVW POINTER              30000000
         B     IRC4                                                     30100000
IRC1     LA    4,MANENTL(4)        ADVANCE TO NEXT MAN TABLE ENTRY      30200000
         B     IRC6                                                     30300000
IRC2     L     1,HASHVAL           END OF DIRECTORY                     30400000
         SR    1,9                                                      30500000
         ICALL DIRWRT                                                   30600000
         BCT   9,IRC0              ADVANCE TO NEXT DIRECTORY            30700000
         DROP  10                                                       30800000
         DROP  4                                                        30900000
         DROP  5                                                        31000000
*                                                                       31100000
DRESTZ2  ICALL LCYLOG                                                   31200000
         IRETURN                                                        31300000
IRM      ICALL MTRCLOSE            CLOSED ALREADY UNLESS WE GET HERE    31400000
         MVI   RTFLG,3             FROM PASS 2 ERROR                    31500000
         ICALL OUTWRTL                                                  31600000
         DC    AL4(IRMSG2)         HINT TO OPERATOR                     31700000
         B     RESCOM2                                                  31800000
         SPACE 2                                                        31900000
DRCRT    L     10,CURWS            MAKE TAPE DIRECTORY RESIDE IN CURWS  32000000
         ST    11,CURWS                                                 32100000
         ST    10,DIRWS            SINCE DISK DIRS READ/WRITE INTO DIRW 32200000
DRNEWDIR TM    CREATING,1                                               32300000
         BZ    RSTXXX                                                   32400000
         ICALL DIRHASH                                                  32500000
         B     DRRDIRZ                                                  32600000
RFTAPE   EQU   *                                                        32700000
RSTXXX   ICALL OUTWRTL                                                  32800000
         DC    AL4(NOOKMSG)                                             32900000
         CANCEL                                                         33000000
DRNOMAN  MVC   NOMWS,WFLLIB-M(11)                                       33100000
         CLI   RTFLG,3             IF THIS IS PASS 2 OF AN INCR REST,   33200000
         BE    DRES1               THE OWNER OF THIS WS WAS DELETED.    33300000
         ICALL OUTWRTL                                                  33400000
         DC    AL4(NOMS)                                                33500000
         B     DRES1                                                    33600000
         TITLE 'SELECTIVE RESTORE ROUTINE'                              33700000
*        RETRIEVE SELECTED WORKSPACES FROM TAPE                         33800000
*         AND WRITE THEM TO LIBRARY DISK.                               33900000
*                                                                       34000000
         ENTRY RETRIEVE                                                 34100000
RETRIEVE PROLOG                                                         34200000
         LM    1,3,=A(WSNBUF,16,WSNBUF+1599) MAX 100 SELECTIONS         34300000
         SR    0,0                                                      34400000
RT1      ICALL SELCARD                                                  34500000
         CLC   0(8,1),RTEND                                             34600000
         BE    RT2                                                      34700000
         BXLE  1,2,RT1             BUILD TABLE OF WSNAMES FOR SEARCH    34800000
         ICALL OUTWRTL             TABLE OVERFLOWED -- NOTIFY OPERATOR  34900000
         DC    AL4(RTMSG)                                               35000000
RT3      ICALL SELCARD             LET SELCARD DO ACTUAL LISTING        35100000
         CLC   0(8,1),RTEND                                             35200000
         BNE   RT3                                                      35300000
         SR    1,2                 BACK TABLE INDEX OFF BY 1 ENTRY      35400000
RT2      BCTR  1,0                                                      35500000
         ST    1,WSNBLIM           FOR BXH END TEST                     35600000
         MVI   RTFLG,1              DOING RETRIEVE, NOT SELREST         35700000
         B     SELST                                                    35800000
RTMSG    DC    C'SELECTION TABLE OVERFLOW -- CARDS BELOW IGNORED'       35900000
         DC    X'FF'                                                    36000000
RTEND    DC    X'80000000'                                              36100000
         DC    AL1(3,ZE,ZN,ZD)                                          36200000
*                                                                       36300000
*                                                                       36400000
*              VERIFY DUMP, INCDUMP, OR SELDUMP TAPE(S)                 36500000
*                                                                       36600000
*        ONLY ONE WS SLOT IS NEEDED BY THE TVERIFY OPERATION            36700000
*                                                                       36800000
         ENTRY TVERIFY                                                  36900000
TVERIFY  PROLOG                                                         37000000
         MVI   RTFLG,X'FF'         NO DISK ACTION AT ALL                37100000
         B     SELST                                                    37200000
         EJECT                                                          37300000
*                                                                       37400000
*        SELECTIVE RESTORE.                                             37500000
*                                                                       37600000
*        WORKSPACES RETRIEVED OR SELECTIVELY RESTORED ARE GIVEN A       37700000
*        TIMESTAMP OF THE PRESENT TIME.  IF THEY RETAINED THEIR TRUE    37800000
*        SAVE TIME, THEY MIGHT SHOW UP IN NEITHER THE PREVIOUS FULL     37900000
*        DUMP NOR IN A FOLLOWING INCREMENTAL DUMP, AND SO THEY WOULD BE 38000000
*        IGNORED IN A RESTORE OPERATION.  SUCH IS THE PRICE OF PROGRESS 38100000
*                                                                       38200000
SELREST  PROLOG                                                         38300000
         ENTRY SELREST                                                  38400000
         MVI   RTFLG,0             DOING SELREST, NOT RETRIEVE          38500000
SELST    BALR  12,0                 ENTRY FOR RETRIEVE                  38600000
         USING *,12                                                     38700000
         L     1,=A(UTDATE)                                             38800000
         MVC   RTS(8),0(1)         EBCDIC DATE                          38900000
         L     1,=A(VTOZ)                                               39000000
         TR    RTS(8),0(1)         ZSYMBOL DATE                         39100000
         MVI   RTS+2,ZSLASH                                             39200000
         MVI   RTS+5,ZSLASH                                             39300000
         GETIME TU                 TIME IN 300THS                       39400000
         ST    1,RTS+8                                                  39500000
         ICALL SETCON                                                   39600000
         ICALL MTROPEN                                                  39700000
         L     10,DIRWS                                                 39800000
SEL0     L     11,CURWS                                                 39900000
SEL1     ICALL MTRD                                                     40000000
         ICALL MTRDZ                                                    40100000
         L     1,=A(MTFLAGS)                                            40200000
         TM    0(1),MTEOF                                               40300000
         BO    SELRESTZ                                                 40400000
         TM    0(1),MTREJ                                               40500000
         BO    SEL1                FORGET IT IF REJECTED BY MTREAD.     40600000
         USING M,11                                                     40700000
         CLC   WFLNAME,DIRTNAME    IGNORE DIRECTORIES                   40800000
         BE    SEL1                                                     40900000
         TM    RTFLG,X'FF'         IS THIS OPERATION A RETRIEVE --      41000000
         BZ    SEL2                NO, SELREST.  ACCEPT ALL TAPE WSS.   41100000
         BM    SEL6                YES.  PREPARE TO SEARCH WSNAME TABLE 41200000
         L     2,=A(UTFLAGS)       TVERIFY.  IF WS LISTING REQUESTED    41300000
         TM    0(2),UTWSLST                                             41400000
         BZ    SEL1                (WHICH IT'S NOT)                     41500000
         MVC   TVMID(16),WFLLIB    MOVE IN WSID                         41600000
         MVC   TVMTS(12),WFLDATE   LIKEWISE TIME STAMP                  41700000
         ICALL OUTWRT              AND LIST THIS WS                     41800000
         DC    AL4(TVMSG)                                               41900000
         B     SEL1                                                     42000000
SEL6     LM    1,2,=A(WSNBUF-16,16)                                     42100000
         L     3,WSNBLIM           END OF WS NAME TABLE                 42200000
         MVI   RTEFLG,1            ASSUME RETRIEVE OPERATION ENDED      42300000
SEL3     BXH   1,2,SEL5            COMPARE TAPE WS AGAINST ALL          42400000
*                                  SELECTED WS LIBS AND NAMES           42500000
         CLI   WFLNAME-WFLLIB(1),X'80' FLAG FOR WS ALREADY RETRIEVED    42600000
         BH    SEL3                IGNORE                               42700000
         MVI   RTEFLG,0            RESET ASSUMPTION OF ALL DONE         42800000
         TM    WFLNAME-WFLLIB(1),X'7F'                                  42900000
         BNZ   SEL3B               X'80' MEANS WE HAVE STARTED          43000000
*                                  RETRIEVING AN ENTIRE LIBRARY BUT     43100000
*                                  HAVEN'T FINISHED IT                  43200000
         CLC   WFLLIB-WFLLIB(4,1),WFLLIB  RETRIEVE IF RIGHT LIBRARY     43300000
         BE    SEL3A               (WHICH IT IS)                        43400000
         TM    WFLNAME-WFLLIB(1),X'80' IF NEW LIB NO. AND WE HAVE BEEN  43500000
*                                  RESTORING A FULL LIBRARY, WE'RE      43600000
*                                  FINISHED WITH THIS LIBRARY.          43700000
         BZ    SEL3                NO, UNRETRIEVED LIBRARY.             43800000
         MVI   WFLNAME-WFLLIB(1),X'FF' YES.  MARK IT UTTERLY RETRIEVED. 43900000
         B     SEL3                                                     44000000
SEL3B    CLC   WFLLIB(16),WFLLIB-WFLLIB(1)                              44100000
         BNE   SEL3                NO MATCH, BACK FOR NEXT TEST         44200000
SEL3A    OI    WFLNAME-WFLLIB(1),X'80' MARK WS AS RETRIEVED             44300000
SEL2     EQU   *                                                        44400000
         ICALL DWRZ                ENSURE DISK OPERATION FINISHED       44900000
         L     1,WFLLIB                                                 45000000
         ICALL GETDIR                                                   45100000
         L     0,WFLLIB                                                 45200000
         ICALL LOC8MAN                                                  45300000
         B     SELNOLIB                                                 45400000
         MVC   WFLDATE(12),RTS                                          45500000
         ICALL WSSAVE                                                   45600000
SEL4     L     1,=A(UTFLAGS)       IF DOUBLE WS BUFFERING IS IN EFFECT, 45700000
         TM    0(1),UT3WSS                                              45800000
         BZ    SEL4A                                                    45900000
         L     11,ALTWS            SWAP BUFFERS AND GO GET NEXT WS      46000000
         MVC   ALTWS(4),CURWS                                           46100000
         ST    11,CURWS                                                 46200000
         B     SEL0                                                     46300000
SEL4A    EQU   *                                                        46400000
         ICALL DWRZ                TO DISK, THEN GO GET NEXT WS         46900000
         B     SEL0                FROM TAPE.                           47000000
*              END UNSUCCESSFUL TABLE SEARCH IN RETRIEVE OPERATION      47100000
SEL5     CLI   RTEFLG,0            IF NO WSNAMES REMAINING IN TABLE,    47200000
         BZ    SEL1                QUIT. ELSE READ NEXT TAPE WS.        47300000
         ICALL MTRCLOSE                                                 47400000
SELRESTZ CLI   RTFLG,X'FF'         IF ENDING A VERIFY OPERATION,        47500000
         BE    SELRZZZ             NO POST-RESTORE CLEANUP.             47600000
         CLI   DIRIN+1,255         SKIP DIR REWRITE IF NO DIR IN CORE   47700000
         BE    SELRZZ                                                   47800000
         LH    1,DIRIN                                                  47900000
         ICALL DIRWRT                                                   48000000
SELRZZ   ICALL LCYLOG                                                   48100000
         CLI   RTFLG,0             IF RETRIEVE OPERATION,               48200000
         BE    SELRZZZ                                                  48300000
         LM    1,2,=A(WSNBUF-16,16) WE MUST LOG THE UNRETRIEVED WSS.    48400000
         L     3,WSNBLIM                                                48500000
SELRZC   BXH   1,2,SELRZZZ                                              48600000
         CLI   WFLNAME-WFLLIB(1),X'80'                                  48700000
         BNL   SELRZC                                                   48800000
         MVC   IRCMWS,WFLLIB-WFLLIB(1)                                  48900000
         ICALL OUTWRTL                                                  49000000
         DC    AL4(IRCMS)                                               49100000
         B     SELRZC                                                   49200000
SELRZZZ  IRETURN                                                        49300000
SELNOLIB MVC   NOMWS,WFLLIB-M(11)                                       49400000
         ICALL OUTWRTL                                                  49500000
         DC    AL4(NOMS)                                                49600000
         B     SEL1                                                     49700000
RTS      DC    3F'0'               TIMESTAMP INFORMATION                49800000
TVMSG    DC    CL7'       '        SPACES TO BE CONSISTENT W/ MTSECT    49900000
         DC    X'13'                                                    50000000
TVMTS    DC    XL12'00'            DATE, TIME                           50100000
         DC    X'11'                                                    50200000
TVMID    DC    XL16'00'            WSID                                 50300000
         DC    X'FF'                                                    50400000
         DROP  11                                                       50500000
         TITLE 'SAVE A WORKSPACE ON THE LIBRARY DISK'                   50600000
*                                                                       50700000
*        SAVE A WORKSPACE                                               50800000
*        REPRODUCE AS MUCH AS POSSIBLE,  )SAVE                          50900000
*        ***** ASSUMES THAT A PRECEDING CALL OF DWRZ HAS ENDED ANY      51000000
*        ***** PREVIOUS WORKSPACE WRITE OPERATION *****                 51100000
*                                                                       51200000
WSSAVE   PROLOG WSAR,WSARZ                                              51300000
         USING M,11                                                     51400000
         STM   0,9,WSAR                                                 51500000
         MVI   ADJQ+1,0            PROG MODIFICATION.                   51600000
         CLI   RTFLG,2             IF INCREST (EITHER PASS),            51700000
         BL    TRCOMPS                                             2221 51800000
         LA    7,ADJQZ             LOCATE THE PERSAVW FOR THIS WS       51900000
         BAL   8,LOC8WS            (WE MAY DISCARD IT ANYWAY)           52000000
         CLI   PSLEN-PERSAVW(3),0  WSNAME FOUND, ERGO NOT DROPPED       52100000
         BCR   7,7                 ALREADY SAVED -- IGNORE THIS COPY    52200000
         SR    3,10                NAME EXISTS BUT NOT WORKSPACE --     52300000
         ST    3,WSPERSAV          REMEMBER LOCATION OF PERSAVW         52400000
TRCOMPS  L     4,=A(CDCBASE)                                       2221 52500000
         L     4,0(4)                                              2221 52600000
         COPY  TRCOMP                                                   52700000
         DROP  11                                                       52800000
         USING M,10                                                     52900000
         ST    1,TRCNT                                                  53000000
*                                                                       53100000
*        CHECK SALVHED FOR A SALVAGED BLOCK OF THE RIGHT SIZE.          53200000
         CLI   RTFLG,2             IF INCREST (EITHER PASS),            53300000
         BNL   EWS3                WE NEED NO MORE PERSAVWS.            53400000
         BCTR  1,0                                                      53500000
         SLL   1,2                                                      53600000
         L     3,SALVHED(1)                                             53700000
         LTR   3,3                                                      53800000
         BZ    EWS2                NO SALVAGED BLOCKS THIS SIZE         53900000
         AR    3,10                                                     54000000
         USING PERSAVW,3                                                54100000
         L     2,PSLINK                                                 54200000
         ST    2,SALVHED(1)                                             54300000
         L     2,PSCYL                                             DASD 54400000
         ST    2,WSCHH                                                  54500000
         MVC   WSFILE(2),PSFILE                                         54600000
         SR    3,10                                                     54700000
         ST    3,WSPERSAV                                               54800000
         B     EWS10                                                    54900000
         DROP  3                                                        55000000
*                                                                       55100000
*              NO PERSAVW AVAILABLE FROM SALVAGED TRACK LIST.           55200000
*              CREATE A PERSAVW FROM FREE-SPACE AREA ABOVE MX.          55300000
EWS2     L     3,DSNXTF            GET PERSAV FROM FREE AREA.           55400000
         LA    2,PSWL(3)                                                55500000
         C     2,MANSTAR           CHECK FOR DIRECTORY OVERFLOW         55600000
         BNL   EWS6                TOO MANY NAMES                       55700000
         ST    2,DSNXTF                                                 55800000
         ST    3,WSPERSAV                                               55900000
*                                                                       56000000
*        SELECT A FILE TO SAVE THIS WORKSPACE ON                        56100000
*        LIB EXTENT IS FULL IF CFREDSK IS LARGER THAN EXTUP.       5981 56200000
*        R3    IS MAX NUMBER OF FREE TRACKS SO FAR.                5981 56300000
*        R4  IS ((EXTUP-CFREDSK) IOTA MAX/EXTUP-CFREDSK)  (/1/)         56400000
*        R5    IS NUMBER OF FREE TRACKS IN EXTENT R2.              5981 56500000
EWS3     L     1,=A(CDCBXLE)                                            56600000
         LM    0,2,0(1)                                                 56700000
         SR    3,3                                                      56800000
MAXS1    SR    5,5                 IF END-CYL MINUS FR-CYL IS MINUS5981 56900000
         LH    8,EXTUP-CDCPARS(2)  END-CYL MINUS FREE-CYL          5981 57000000
         SH    8,CFREDSK-CDCPARS(2)                                5981 57100000
         BM    MAXS4               ONLY IF EXTENT IS FULL          5981 57200000
         LH    5,2+EXTUP-CDCPARS(2) END-HEAD MINUS FREE-HEAD       5981 57300000
         SH    5,2+CFREDSK-CDCPARS(2)                              5981 57400000
         BNM   MAXS3               BRANCH IF HEAD DIFF NOT MINUS   5981 57500000
         LTR   8,8                                                 5981 57600000
         BZ    MAXS4               BR IF EXTENT IS FULL            5981 57700000
         BCTR  8,0                 IF MINUS, DECR CYL DIFF         5981 57800000
         AH    5,HMAX-CDCPARS(2)   AND GET NO. TRKS MINUS 1        5981 57900000
MAXS3    MH    8,CCADJ-CDCPARS+2(2) MULT CYL BY MINUS TRKS/CYL     5981 58000000
         LPR   8,8                                                 5981 58100000
MAXS4    LA    5,1(8,5)            GET TOTAL FREE TRACKS           5981 58200000
         CR    3,5                                                      58300000
         BH    MAXS2                                                    58400000
         LR    3,5                 NEW MAX FREE TRACKS             5981 58500000
         LR    4,2                                                      58600000
MAXS2    BXLE  2,0,MAXS1                                                58700000
         L     2,TRCNT             TRACK COUNT THIS WS                  58800000
         A     2,CFREDSK                                                58900000
*        FREEDSK IS IN FORM CCHH                                   DASD 59000000
EWS1     EX    2,EWS5              CHECK FOR HEAD GTR LIMIT             59100000
         BH    EWS9                                                     59200000
         A     2,CCADJ                                                  59300000
         B     EWS1                                                     59400000
EWS9     C     3,TRCNT             TRKS AVAILABLE VS.TRKS NEEDED   5981 59500000
         BL    EWS4                NO ROOM IN FREE AREA            5981 59600000
         L     0,CFREDSK                                                59700000
         ST    2,CFREDSK           RESERVE TRACKS                       59800000
         ST    0,WSCHH                                                  59900000
         L     1,=A(ADPAR)                                              60000000
         S     4,0(1)                                                   60100000
         STH   4,WSFILE                                                 60200000
         CLI   RTFLG,2             IF SELREST (EITHER PASS), NO NEED TO 60300000
         BNL   WSS3                LOCATE PERSAVW AGAIN                 60400000
*                                                                       60500000
*              REENTRY WHEN PERSAVW WAS FOUND ON SALVAGED-TRACK LIST    60600000
EWS10    LA    8,WSS2              FOUND EXIT                           60700000
         LA    7,WSS3              NOT FOUND EXIT                       60800000
*                                                                       60900000
*                                  LOCATE-WS PSEUDO-SUBROUTINE          61000000
LOC8WS   L     0,WFLLIB-M(11)                                           61100000
         ICALL LOC8MAN                                                  61200000
         B     ADJQZ               MAN NOT FOUND -- IGNORE QUIETLY      61300000
         ST    1,WSSMAN                                                 61400000
         ST    1,WSSLINK                                                61500000
         USING PERSAVW,3                                                61600000
         L     3,LIBLINK-PERLIB(1)                                      61700000
WSS1     LTR   3,3                                                      61800000
         BCR   8,7                 NO WS OF SAME NAME                   61900000
         AR    3,10                                                     62000000
         SR    1,1                                                      62100000
         IC    1,PSNAME                                                 62200000
         EX    1,WSCLC                                                  62300000
         BCR   8,8                 SAME-NAME WS FOUND                   62400000
         ST    3,WSSLINK                                                62500000
         L     3,PSLINK                                                 62600000
         B     WSS1                                                     62700000
WSCLC    CLC   PSNAME(0),WFLNAME-M(11)                                  62800000
*                                                                       62900000
*              SAME-NAME WS FOUND IN THIS LIBRARY.  PURGE IT.           63000000
WSS2     L     2,PSLINK            REMOVE FROM LIBRARY.                 63100000
         L     1,WSSLINK                                                63200000
         ST    2,PSLINK-PERSAVW(1)                                      63300000
         SR    1,1                                                      63400000
         IC    1,PSLEN                                                  63500000
         BCTR  1,0                                                      63600000
         SLL   1,2                                                      63700000
         L     2,SALVHED(1)                                             63800000
         ST    2,PSLINK                                                 63900000
         SR    3,10                                                     64000000
         ST    3,SALVHED(1)                                             64100000
         MVI   ADJQ+1,X'F0'        DON'T ADJUST QUOTA FOR THIS.         64200000
*                                                                       64300000
*              PUT WS INFO INTO NEW PERSAVW ON LIBRARY LIST.            64400000
*              MOST OF THIS IS IRRELEVANT FOR INCREMENTAL RESTORE.      64500000
WSS3     L     3,WSPERSAV                                               64600000
         AR    3,10                                                     64700000
         USING PERSAVW,3                                                64800000
         MVC   PSCYL,WSCHH         CYLINDER, HEAD                  DASD 64900000
         MVC   PSLEN,TRCNT+3       TRACK COUNT                          65000000
         MVC   PSFILE(2),WSFILE                                         65100000
         CLC   WFLNAME-M(9,11),CONTINUE  NO QUOTA BUMPING IF WS IS CONT 65200000
         BNE   *+8                                                      65300000
         MVI   ADJQ+1,X'F0'                                             65400000
         CLI   RTFLG,2             ON SELREST (EITHER PASS), PERSAVW IS 65500000
         BNL   WSS4                ALREADY LINKED INTO LIST             65600000
         MVC   PSMAN,WFLMAN-M(11)  REMEMBER SAVER                       65700000
         MVC   PSNAME,WFLNAME-M(11)  AND WSNAME                         65800000
         MVC   PSPASS,WFLPASS-M(11)  AND PASSWORD                       65900000
         L     1,WSSMAN                                                 66000000
         L     0,LIBLINK-PERLIB(1)                                      66100000
         ST    0,PSLINK            ADD THIS WS TO TOP OF LIST OF SAVED  66200000
         SR    3,10                WORKSPACES IN THIS LIBRARY           66300000
         ST    3,LIBLINK-PERLIB(1)                                      66400000
WSS4     L     1,WSCHH                                                  66500000
         LH    2,WSFILE                                                 66600000
         ICALL DWR                 WRITE WORKSPACE TO DISK              66700000
*        ADJUST MANWSA                                                  66800000
ADJQ     BC    0,ADJQZ             PROGRAM MODIFIED.                    66900000
         L     1,WSSMAN                                                 67000000
         L     0,WFLLIB-M(11)                                           67100000
         C     0,=F'1000'          COMMON VS PRIVATE LIBRARY            67200000
         BNL   ADJQ1                                                    67300000
         L     1,WFLMAN-M(11)                                           67400000
         ICALL GETDIR                                                   67500000
         L     0,WFLMAN-M(11)                                           67600000
         ICALL LOC8MAN                                                  67700000
         B     ADJQZ               COMMON LIBRARY WS WITH NO SAVER.     67800000
ADJQ1    LH    2,MANWSA-PERLIB(1)                                       67900000
         LA    2,1(2)                                                   68000000
         STH   2,MANWSA-PERLIB(1)                                       68100000
         CH    2,MANWSQ-PERLIB(1)                                       68200000
         BNH   *+8                                                      68300000
         STH   2,MANWSQ-PERLIB(1)                                       68400000
ADJQZ    LM    0,9,WSAR                                                 68500000
         IRETURN                                                        68600000
EWS5     CLI   HMAX+1,0                                                 68700000
EWS4     ICALL OUTWRTL             DISK FULL                            68800000
         DC    AL4(DFTX)                                                68900000
         B     EWS7                                                     69000000
EWS6     ICALL OUTWRTL             DIRECTORY FULL                       69100000
         DC    AL4(DHFMS)                                               69200000
EWS7     LH    1,DIRIN             AT LEAST ASSURE THAT DIRECTORIES     69300000
         ICALL DIRWRT              REFLECT LIBRARY STATE                69400000
         CANCEL                                                         69500000
CONTINUE DC    AL1(8,ZC,ZO,ZN,ZT,ZI,ZN,ZU,ZE)                           69600000
         DROP  3,4                                                      69700000
         DROP  10                                                       69800000
WSAR     DSECT                                                          69900000
TRCNT    DC    F'0'                                                     70000000
WSSMAN   DC    F'0'                                                     70100000
WSCHH    DC    F'0'                                                     70200000
WSSLINK  DC    F'0'                                                     70300000
WSPERSAV DC    F'0'                                                     70400000
WSFILE   DC    H'0'                                                     70500000
WSARZ    EQU   *                                                        70600000
RSTRSECT CSECT                                                          70700000
         TITLE 'SUBROUTINES'                                            70800000
         SPACE                                                          70900000
GETDIR   PROLOG GETS,GETSZ                                              71000000
         STM   0,10,GETS                                                71100000
         SR    0,0                                                      71200000
         D     0,HASHVAL                                                71300000
         LR    1,0                                                      71400000
         CLI   DIRIN+1,255                                              71500000
         BE    RDONLY                                                   71600000
         CH    1,DIRIN                                                  71700000
         BE    GETDIRZ                                                  71800000
         STH   1,NXTDIR                                                 71900000
         LH    1,DIRIN                                                  72000000
         ICALL DIRWRT                                                   72100000
         LH    1,NXTDIR                                                 72200000
RDONLY   STH   1,DIRIN                                                  72300000
         ICALL DIRREAD                                                  72400000
GETDIRZ  LM    0,10,GETS                                                72500000
         IRETURN                                                        72600000
GETS     DSECT                                                          72700000
         DS    11F                                                      72800000
GETSZ    EQU   *                                                        72900000
RSTRSECT CSECT                                                          73000000
         SPACE 3                                                        73100000
SETCON   PROLOG                                                         73200000
         L     1,=A(WSLEN)         PICK UP INSTALLATION DEPENDENT VALUE 73300000
         L     1,0(1)                                                   73400000
         ST    1,WLEN              WORKSPACE LENGTH.                    73500000
         L     1,=A(KMANHASH)      NUMBER OF DIRECTORIES.               73600000
         L     1,0(1)                                                   73700000
         ST    1,HASHVAL                                                73800000
         L     1,=A(WSLOC)                                              73900000
         MVC   DIRWS(12),0(1)                                           74000000
         MVI   DIRIN+1,255                                              74100000
         IRETURN                                                        74200000
         SPACE                                                          74300000
DIRCT    DC    F'0'                                                     74400000
NOMS     DC    C'LIBRARY NUMBER NOT FOUND'                              74500000
         DC    X'11'                                                    74600000
NOMWS    DC    XL16'00'                                                 74700000
         DC    X'FF'                                                    74800000
NOOKMSG  DC    C'INCORRECT NUMBER OF DIRECTORIES ON TAPE'               74900000
         DC    X'FF'                                                    75000000
IRMSG1   DC    C'LIBRARY RESTORE TO '                                   75100000
         DC    X'13'                                                    75200000
IRMSTS   DC    XL12'00'                                                 75300000
         DC    X'FF'                                                    75400000
IRMSG2   DC    C'MOUNT '                                                75500000
         DC    X'13'                                                    75600000
FDTS     DC    XL12'00'                                                 75700000
         DC    C' FULL-DUMP TAPE FILE',X'FF'                            75800000
IRMSG3   DC    C'MISMATCH OF DUMP DATES.'                               75900000
         DC    X'FF'                                                    76000000
IRMSG4   DC    C'NOT A FULL-DUMP TAPE',X'FF'                            76100000
IRCMS    DC    C'NOT FOUND ON TAPE'                                     76200000
         DC    X'11'                                                    76300000
IRCMWS   DC    XL16'00'                                                 76400000
         DC    X'FF'                                                    76500000
         TITLE 'APL UTILITY CREATE FUNCTION'                            76600000
*                                                                       76700000
*                                                                       76800000
*        CREATE A NEW SET OF DIRECTORIES AND RESTORE FROM TAPE.         76900000
*                                                                       77000000
*        FIRST, WRITE MANHASH EMPTY DIRECTORIES.                        77100000
*        THEN, PERFORM ''ADDS'' TO THEM FROM MAN TABLE FROM TAPE.       77200000
*        WHEN THIS HAS BEEN DONE, CARRY ON LIKE A RESTORE.              77300000
*                                                                       77400000
         SPACE                                                          77500000
CREATE PROLOG                                                           77600000
         ENTRY CREATE                                                   77700000
         MVI   CREATING,1                                               77800000
         ICALL SETCON                                                   77900000
CREATE2  ICALL MTROPEN             OPEN INPUT TAPE FILE.                78000000
         L     11,CURWS                                                 78100000
         ICALL MTRD                READ IN A DIRECTORY.                 78200000
         ICALL MTRDZ                                                    78300000
         L     1,=A(MTFLAGS)       ARTIFICIALLY CLOSE.                  78400000
         TM    0(1),MTREJ          IF DIRECTORY WAS NOT READ            78500000
         BO    CREATE0               SUCESSFULLY, REJECT IT.            78600000
         MVI   0(1),0              FORCE REWIND ON NEXT TAPE OPEN       78700000
         USING M,11                                                     78800000
         CLC   WFLNAME,DIRTNAME                                         78900000
         BNE   CREATE0             NOT A DIRECTORY                      79000000
         CLC   DFDTS(12),DIDTS     MAKE SURE IT'S NOT AN INCDUMP TAPE   79100000
         BE    CREATE1             FULL DUMP OR DISTRIBUTION SELDUMP    79200000
CREATE0  ICALL OUTWRTL                                                  79300000
         DC    AL4(IRMSG4)                                              79400000
         ICALL MTRCLOSE            REWIND UNLOAD ALIEN TAPE             79500000
         B     CREATE2             TRY AGAIN                            79600000
*        FORMAT ALL LIBRARY DISKS.                                      79700000
CREATE1  L     3,=A(CDCBXLE)                                            79800000
         LM    4,5,0(3)                                                 79900000
         L     3,8(3)                                                   80000000
CRFMT    ST    3,FMTPARS+4                                              80100000
         STM   3,5,CRTS35                                               80200000
         LA    1,FMTPARS                                                80300000
         ICALL DISKFMT                                                  80400000
         LM    3,5,CRTS35                                               80500000
         BXLE  3,4,CRFMT                                                80600000
*                                                                       80700000
*        WRITE MANHASH EMPTY DIRECTORIES.                               80800000
*                                                                       80900000
         L     11,CURWS                                                 81000000
         L     1,QSYMBOT                                                81100000
         S     1,=A(STPARAM+8-STFREG)                                   81200000
         S     1,=A(MANENTL)                                            81300000
         ST    1,MANSTAR                                                81400000
         L     0,=F'-1'                                                 81500000
         ST    0,M(1)                                                   81600000
         XC    SALVHED(256),SALVHED                                     81700000
         XC    SALVHED+256(FIRSTENT-SALVHED-256),SALVHED+256            81800000
         MVC   VVMM(4),=C'V1M1'    DIRECTORY IS FOR V1, M1         C059 81900000
         MVC   NUMDIRS(4),HASHVAL  NO. DIRECTORIES                 C059 82000000
         LA    2,FIRSTENT-M                                             82100000
         ST    2,DSNXTF                                                 82200000
         LR    10,11                                                    82300000
         SR    1,1                 SET DIRECTORY NUMBER TO ZERO.        82400000
WRITEMP  ST    1,WFLMAN                                                 82500000
         ST    1,WFLLIB              WFLLIB = WFLMAN FOR NEATNESS, ETC. 82600000
         ICALL DIRWRT              WRITE A DIRECTORY.                   82700000
         L     1,WFLMAN                                                 82800000
         LA    1,1(1)              INCREMENT DIRECTORY NUMBER.          82900000
         C     1,HASHVAL           SEE IF WE'RE DONE.                   83000000
         BL    WRITEMP             WRITE ANOTHER IF NOT.                83100000
         ICALL INIT,*              INITIALIZE CFREDSK              3579 83200000
         ICALL DREST               NOW DO A RESTORE, SORT OF.           83300000
         MVI   CREATING,0                                               83400000
         IRETURN                                                        83500000
CRTS35   DC    3F'0'                                                    83600000
         DROP  11                                                       83700000
INIT     PROLOG ,                                                  3579 83800000
         L     3,=A(CDCBXLE)       SET ALL CREFDSK'S TO EXLOW.     3579 83900000
         LM    0,2,0(3)            NOT NECESSARY UNLESS SOME OTHER 3579 84000000
         USING CDCPARS,2                                           3579 84100000
INIT2    MVC   CFREDSK,EXTLOW      UTILITY OPERATION PROCEEDED     3579 84200000
         BXLE  2,0,INIT2           THIS ONE.                       3579 84300000
         L     2,8(3)              NEED EXTENT 0 AGAIN.            3579 84400000
         L     1,HASHVAL           RESET EXTENT 0 CREFDSK TO       3579 84500000
         SLA   1,3                 1ST TRACK PAST LAST DIR.        3579 84600000
         A     1,=A(DIRTAB)                                        3579 84700000
         MVC   CFREDSK,0(1)                                        3579 84800000
         DROP  2                                                   3579 84900000
         IRETURN                                                   3579 85000000
         EJECT                                                          85100000
*                                                                       85200000
*                                                                       85300000
*        ADD USERS TO DIRECTORIES.                                      85400000
*        CURWS=R11=DIRECTORY JUST READ FROM TAPE                        85500000
*                                                                       85600000
DIRHASH  PROLOG                                                         85700000
         USING M,10                                                     85800000
         LM    10,11,DIRWS ,CURWS                                       85900000
         SR    1,1                                                      86000000
HASH1    STH   1,DIRIN                                                  86100000
         ICALL DIRREAD                                                  86200000
         L     5,MANSTAR-M(11)                                          86300000
         AR    5,11                                                     86400000
         L     4,MANSTAR                                                86500000
HASH1A   SR    2,2                                                      86600000
         L     3,0(5)                                                   86700000
         C     3,=F'-1'                                                 86800000
         BE    ODIRZ                                                    86900000
         D     2,HASHVAL                                                87000000
         CH    2,DIRIN                                                  87100000
         BNE   HASH2                                                    87200000
         S     4,=A(MANENTL)                                            87300000
         C     4,DSNXTF                                                 87400000
         BNH   DHFUL                                                    87500000
         LA    6,0(4,10)                                                87600000
         USING PERLIB,6                                                 87700000
         MVC   PERLIB(MANENTL),0(5)                                     87800000
         MVC   LIBLINK,ZEROD       ELIMINATE LINK                       87900000
         MVC   MANWSA(2),ZEROD     INITIALIZE WS COUNT.   10-04-68      88000000
HASH2    LA    5,MANENTL(5)                                             88100000
         B     HASH1A                                                   88200000
ODIRZ    ST    4,MANSTAR                                                88300000
         LH    1,DIRIN                                                  88400000
         ICALL DIRWRT                                                   88500000
         LH    1,DIRIN                                                  88600000
         LA    1,1(1)                                                   88700000
         C     1,HASHVAL                                                88800000
         BL    HASH1                                                    88900000
         IRETURN                                                        89000000
DHFUL    ICALL OUTWRTL                                                  89100000
         DC    AL4(DHFMS)                                               89200000
         CANCEL                                                         89300000
         DROP  10                                                       89400000
         DROP  6                                                        89500000
DHFMS    DC    C'DIRECTORIES FULL -- UTILITY CANCELLED'                 89600000
         DC    X'FF'                                                    89700000
ZEROD    DC    F'0'                                                     89800000
*                                                                       89900000
         LTORG                                                          90000000
         EJECT                                                          90100000
DFTX     DC    C'LIBRARY PACKS FULL -- UTILITY CANCELLED'               90200000
         DC    X'FF'                                                    90300000
DIRWS    DC    3A(0)                                                    90400000
CURWS    EQU   DIRWS+4                                                  90500000
ALTWS    EQU   DIRWS+8                                                  90600000
DIRIN    DC    H'0'                                                     90700000
NXTDIR   DC    H'0'                                                     90800000
HASHVAL  DC    A(0)                                                     90900000
WLEN     DC    F'0'                                                     91000000
FMTPARS  DC    5A(0)                                                    91100000
DIRTNAME DC    C'APLDIRECTORY'                                          91200000
SELECTV  DC    X'00'                                                    91300000
CREATING DC    FL1'0'                                                   91400000
RTFLG    DC    X'00'                                                    91500000
*              = 0 ORDINARY FULL RESTORE OR SELECTIVE RESTORE           91600000
*              = 1 RETRIEVE                                             91700000
*              = 2 INCREMENTAL RESTORE, PASS 1                          91800000
*              = 3 INCREMENTAL RESTORE, PASS 2                          91900000
RTEFLG   DC    X'00'               RETRIEVE OPERATION ENDED             92000000
WSNBLIM  DS    A                   LIMIT ON WSNBUF                      92100000
WSNBUF   DS    404F                16-BYTE WS LIB, NAME ENTRIES FOR     92200000
*                                  RETRIEVE                             92300000
         COPY  CDCPARS                                                  92400000
EMWSV    DSECT                                                          92500000
         DS    8F                                                       92600000
EMWSVE   EQU   *                                                        92700000
         COPY  DIRSECT                                                  92800000
         END                                                            92900000
./  ADD    NAME=APLUTAPE
TAPE     TITLE 'APL UTILITY MAGNETIC TAPE ROUTINES            05/11/70' 00060000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00120000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00180000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00240000
         PRINT OFF                                                      00300000
         MACRO                                                          00360000
&NAME    EXCP  &CCB                                                     00420000
         AIF   ('&CCB' EQ '').L6                                        00540000
         AIF   ('&CCB'(1,1) EQ '(').L1                                  00600000
&NAME    L     1,=A(&CCB)                                               00660000
         AGO   .L4                                                      00720000
.L1      AIF   ('&CCB'(2,2) EQ '1)').L5                                 00780000
&NAME    LR    1,&CCB(1)                                                00840000
.L4      AGO   .A1                                                      00900000
.A1      ANOP                                                           01140000
         ICALL OSMTEXCP                                                 01200000
         MEXIT                                                          01260000
.L6      MNOTE 5,'NO CCB SPECIFIED - MACRO IGNORED.'                    01320000
         MEXIT                                                          01380000
.L5      ANOP                                                           01440000
&NAME    ICALL OSMTEXCP                                                 01740000
         MEND                                                           01800000
         SPACE                                                          01860000
         MACRO                                                          01920000
&NAME    WAIT  &CCB                                                     01980000
         GBLA  &WCNT                                                    02100000
         AIF   (T'&CCB NE 'O').L1                                       02160000
         MNOTE 5,'CCB OMITTED - MACRO IGNORED.'                         02220000
         MEXIT                                                          02280000
.L1      AIF   ('&CCB'(1,1) EQ '(').L2                                  02340000
&NAME    L     1,=A(&CCB)                                               02400000
         AGO   .L3                                                      02460000
.L2      AIF   ('&CCB'(2,2) EQ '1)').L4                                 02520000
&NAME    LR    1,&CCB(1)                                                02580000
         AGO   .L3                                                      02640000
.L4      ANOP                                                           02700000
&NAME    TM    2(1),X'80'                                               02760000
         AGO   .L5                                                      02820000
.L3      TM    2(1),X'80'                                               02880000
.L5      ANOP                                                           02940000
         BO    WAIT&WCNT                                                03300000
         ICALL OSMTWAIT                                                 03360000
WAIT&WCNT EQU  *                                                        03420000
&WCNT    SETA  &WCNT+1                                                  03480000
         MEND                                                           03540000
         SPACE                                                          03600000
         MACRO                                                          03660000
&L       SYSDATE &T,&S                                                  03720000
         AIF   (T'&S EQ 'O').S2                                         04260000
&L       TIME  DEC                                                      04380000
         ST    1,&S                                                     04440000
         UNPK  &T.(6),&S+1(3)                                           04500000
         OI    &T+5,X'F0'                                               04560000
         MVI   &T,C' '                                                  04620000
         MEXIT                                                          04680000
.S2      MNOTE 5,'SCRATCH WORD REQUIRED FOR OS.  MACRO IGNORED'         04740000
         MEND                                                           04800000
         SPACE                                                          04860000
         MACRO                                                          04920000
&L       SWITCH                                                         04980000
&L       XI    MTDCCB+7,1                                               05100000
         MVC   CTLCCB+6(2),MTDCCB+6                                     05160000
         L     1,DCBCUR                                                 05340000
         MVC   DCBCUR(4),DCBALT                                         05400000
         ST    1,DCBALT                                                 05460000
         MEND                                                           05520000
         SPACE                                                          05580000
         MACRO                                                          05640000
&L       SETLU                                                          05700000
&L       MVI   MTDCCB+7,5                                               05820000
         MVC   CTLCCB+6(2),MTDCCB+6                                     05880000
         MVC   DCBCUR(8),=A(MTDCB5,MTDCB4)                              06060000
         MEXIT                                                          06120000
         MEND                                                           06480000
         PRINT ON,GEN                                                   06540000
         EXTRN APLMODAD                                                 06780000
         EXTRN CMD                                                      06840000
         EXTRN DWSLOG                                                   06900000
         EXTRN OUTWRT                                                   06960000
         EXTRN OUTWRTL            SUPER-DUPER MESSAGE-WRITER            07020000
         EXTRN UTFLAGS                                                  07080000
         EXTRN WSLEN                                                    07140000
         PRINT OFF                 COPY APLDEFN                         07200000
         COPY APLDEFN                                                   07260000
MTSECT   CSECT                                                          07320000
         PRINT ON,GEN                                                   07380000
         TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT OPEN         05/11/70' 07440000
*                                                                       07500000
*        OPEN - SET UP AND WRITE HEADER LABEL.                          07560000
*                                                                       07620000
         SPACE                                                          07680000
         ENTRY MTWOPEN                                                  07740000
MTWOPEN  PROLOG  MTSAVAR,MTSAVR2Z                                       07800000
         STM   1,2,MTSAVR1                                              07860000
         MVI   MTWOR+1,0           PROGRAM MODIFICATION.                07920000
         LA    2,MTLABAR           LABEL AREA.                          07980000
         USING TFLAB,2                                                  08040000
         TM    MTFLAGS,FILOPEN     CHECK FOR FIRST REEL.                08100000
         BO    MTWO1               BRANCH IF NOT.                       08160000
         MVC   MTVOLSEQ(2),=C'00'  OTHERWISE, INITIALIZE REEL NUMBER.   08220000
         SETLU                                                          08280000
MTWO1    SWITCH                                                         08340000
MTWO2    ICALL MTLABCK             CHECK LABELS.                        08400000
         SPACE                                                          08460000
*        SET UP HEADER LABEL.                                           08520000
         SPACE                                                          08580000
         MVC   TFTYPE(TFCDAT-TFLAB),APLHDR FIRST PART.                  08640000
         SYSDATE TFCDAT,SAVETEMP   CREATION DATE                        08700000
         MVC   TFEDAT(TFLABZ-TFEDAT),APLLR REMAINDER OF ALBEL.          08760000
         SPACE                                                          08820000
*                                                                       08880000
*        OPEN NEW FILE.                                                 08940000
*                                                                       09000000
         SPACE                                                          09060000
MTWOR    BC    0,MTWOZ1            PROGRAM MODIFIED.                    09120000
*                                  TO PREVENT MULTIPLE INCREASE OF      09180000
*                                  VOL NUMBER.                          09240000
         TR    MTVOLSEQ+1(1),EBCDEC INCREMENT REEL NUMBER.              09300000
         CLI   MTVOLSEQ+1,C'0'     CHECK FOR OVERFLOW.                  09360000
         BNE   MTWOZ1                                                   09420000
         TR    MTVOLSEQ(1),EBCDEC  99 REELS IS ENOUGH FOR ANYONE.       09480000
*        LABEL CHECKING ROUTINE LEAVES THE TAPE POSITIONED FOR THE      09540000
*        HEADER LABEL.                                                  09600000
MTWOZ1   MVC   TFVSEQ+2(2),MTVOLSEQ  MOVE IN REEL NUMBER.               09660000
         MVC   TFBLKCT(4),TRECLEN  WRITE BLOCK LENGTH IN LABEL.         09720000
         MVI   RETRIES,0                                                09780000
MTWOZ2   MVI   CTLCCW,TWRITE       WRITE HEADER LABEL.                  09840000
         EXCP  CTLCCB              ASSUME DCB'S HAVE BEEN OPENED.       12060000
         WAIT  (1)                                                      12120000
*  THIS CODE RETRIES WRITE IF UNIT EXCEPTION OCCURRED ON PREVIOUS       12180000
*  BACKSPACE-RECORD (THIS CAN OCCUR IF BSR SENSES FOIL STRIP OR         12240000
*  A TAPE-MARK).  THE CONDITION CAUSED HDR1 TO BE OMITTED               12300000
*  BECAUSE SUCCEEDING WRITE-TAPE-MARK RESETS THE ERROR CONDITION.       12360000
*                                                                       12420000
DCBIFLGS EQU   X'2C'               OFFSET TO DCBIFLGS                   12480000
DCBOFLGS EQU   X'30'          OFFSET TO DCBOFLGS                   6020 12540000
DCBIOBAD EQU   X'1C'               OFFSET TO DCBIOBAD                   12600000
EVNTCB   EQU   X'28'               OFFSET TO ECB (FROM IOB)             12660000
         L     LKR,=A(DCBCUR)      PTR TO CURRENT DCB                   12720000
         L     LKR,0(LKR)          ADDR OF OPENED DCB                   12780000
         NI    DCBIFLGS(LKR),X'3F' TURN OFF ERROR BITS IN DCBIFLGS      12840000
         L     LKR,DCBIOBAD(LKR)   ADDR OF IOB                          12900000
         CLI   EVNTCB(LKR),X'44'   CHECK FOR INTERCEPT ON BSR           12960000
         BE    MTWOZ2              BRANCH IF INT, RETRY WRITE           13020000
MTWO3    ICALL LOGMTLAB            LOG HEADER LABEL                     13140000
         MVI   CTLCCW,WEF          TAPE MARK MUST FOLLOW LAST HDR       13200000
         EXCP  (1)                                                      13260000
         WAIT  (1)                                                      13320000
         OI    MTFLAGS,FILOPEN     MARK FILE OPEN.                      13380000
         LM    1,2,MTSAVR1                                              13440000
         IRETURN                                                        13500000
         DROP  2                                                        13560000
         SPACE                                                          13620000
MTVOLSEQ DC    C'00'                                                    13680000
RETRIES  DC    X'00'                                                    13740000
RETRYTR  DC    X'0102030405060708090A0B00'                              13800000
COMREJ   EQU   X'80'                                                    13860000
FILPROT  EQU   X'02'                                                    13920000
CTLSENSE DC    XL2'00'                                                  13980000
         TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT CLOSE        05/11/70' 14040000
*                                                                       14100000
*        CLOSE LAST OUTPUT FILE.                                        14160000
*                                                                       14220000
         ENTRY MTWCLOSE                                                 14280000
MTWCLOSE PROLOG MTSAVAR,MTSAVR5Z                                        14340000
         STM   0,4,MTSAVR1                                              14400000
         OI    MTFLAGS,CLOSING     MAKE SURE MTWRZ DOESN'T WRITE EOV.   14460000
         ICALL MTWRZ               MAKE SURE ALL WRITES ARE COMPLETE.   14520000
         MVC   MTLABAR(3),=C'EOF'  END OF FILE TRAILER.                 14580000
         LA    4,MTTRLBL           WRITE TRAILER LABEL & SHOW OPERATOR  14640000
         BALR  3,4                                                      14700000
         MVI   MTFLAGS,0           RESET ALL FLAGS.                     14760000
         LM    0,4,MTSAVR1                                              14820000
         IRETURN                                                        14880000
         TITLE 'APL UTILITY MAGNETIC TAPE OUTPUT LABEL CHECKING'        14940000
MTLABCK  PROLOG MTSAVAR,MTREPZ                                          15000000
         STM   1,2,MTSAVR1                                              15060000
         XC    MTLABAR(80),MTLABAR ZERO LABEL AREA.                     15120000
         MVC   VOLID(6),=C'*NOLBL'   VOLID FOR UNLABELED TAPES          15180000
         L     2,DCBCUR                                                 15360000
         OPEN  ((2),(OUTPUT))                                           15420000
         TM    DCBOFLGS(2),X'10'   WAS OPEN SUCCESSFUL ?           6020 15480000
         BO    MTNEWTAP       YES IT WAS                           6020 15540000
         ABEND 1550,DUMP                                           6020 15600000
MTNEWTAP MVI   CTLCCW,REW          REWIND THE TAPE.                     15720000
         EXCP  CTLCCB                                                   15780000
         WAIT  (1)                                                      15840000
         MVI   CTLCCW,TREAD        READ THE LABEL, IF ANY.              15900000
RDLBL    EXCP  (1)                                                      15960000
         WAIT  (1)                                                      16020000
         LA    2,MTLABAR           BEGIN LABEL CHECK                    16080000
         USING TFLAB,2                                                  16140000
         CLC   TFTYPE(3),=C'VOL'   CHECK FOR A VOL LABEL.               16200000
         BE    VOLLBL              PRESERVE IT IF FOUND                 16260000
         CLC   TFTYPE(4),=C'HDR1'  SEE IF TAPE IS LABELLED.             16320000
         BNE   MTLABOK             WRITE ON IT IF NOT.                  16380000
         TM    MTFLAGS,FILOPEN     CHECK FOR FIRST REEL.                16440000
         BZ    MTLABC1             CHECK EXPIRY IF NOT.                 16500000
         CLC   TFLAB(TFVSEQ-TFLAB),PREVLAB OTHERWISE, SEE IF SAME AS    16560000
         BNE   MTLABC1             PREVIOUS. EXPIRY CHECK IF NOT.       16620000
         CLC   TFCDAT(6),PREVDAT   CHECK CREATION DATE FOR AGREEMENT.   16680000
         BE    MTLABOK             IF AGREES, ANOTHER VOLUME OF ACCEPTE 16740000
         SPACE                                                          16800000
*        EXPIRATION CHECK.                                              16860000
         SPACE                                                          16920000
MTLABC1  MVC   PREVLAB(TFVSEQ-TFLAB),TFLAB  SAVE FOR FUTURE CHECKS.     16980000
         MVC   PREVDAT(6),TFCDAT                                        17040000
MTLABSW  BC    0,MTLABOK           SWITCH FOR IGNORE RESPONSE $$$$$     17100000
         SYSDATE TODAYDAT,SAVETEMP   TODAY'S DATE                       17160000
         CLC   TFEDAT(6),TODAYDAT                                       17220000
         BL    MTLABOK             BRANCH IF EXPIRED.                   17280000
         ICALL LOGMTLAB            PRINT PART OF THE LABEL.             17340000
         ICALL OUTWRTL             WRITE NOT EXPIRED MESSAGE            17400000
         DC    AL4(EXPMSG)                                              17460000
MTCKM1   LA    1,MTREP             POINT TO REPLY AREA                  17520000
         LR    0,1                                                      17580000
         ICALL OUTWRTL                                                  17640000
         DC    AL4(REPMSG)                                              17700000
         OC    MTREP(7),=CL7' '    FOLD TO UPPER CASE                   17760000
         CLC   MTREP(7),=C'NEWTAPE'                                     17820000
         BE    MTNEWTAP            NEWTAPE MEANS HE MOUNTED ANOTHER     17880000
         CLC   MTREP(6),=C'IGNORE' IGNORE MEANS OKAY TO WRITE           17940000
         BNE   MTCKM1                                                   18000000
         MVI   MTLABSW+1,X'F0'     SET IGNORE SWITCH  $$$$$ $$$$$       18060000
         B     MTNEWTAP            MAKE SURE TAPE HAS BEEN CHANGED      18120000
*                                                                       18180000
*        REMEMBER VOLID FROM VOL1 LABEL FOR INSERTION INTO HDR1         18240000
*                                                                       18300000
VOLLBL   CLI   TFNUM,C'1'          IGNORE ALL BUT VOL1 LABELS           18360000
         BNE   RDLBL                                                    18420000
         MVC   VOLID(6),TFFID      SAVE VOLID                           18480000
         B     RDLBL                                                    18540000
*                                                                       18600000
*        TAPE MAY BE WRITTEN ON                                         18660000
*                                                                       18720000
MTLABOK  MVI   CTLCCW,BSR          BACKSPACE TO POSITION.               18780000
         EXCP  CTLCCB                                                   18840000
         WAIT  (1)                                                      18900000
         MVI   MTLABSW+1,X'00'     RESET IGNORE SWITCH $$$$$ $$$$$      18960000
         LM    1,2,MTSAVR1                                              19020000
         IRETURN                                                        19080000
         SPACE                                                          19140000
PREVLAB  DC    CL27' '                                                  19200000
PREVDAT  DC    CL6' '                                                   19260000
TODAYDAT DC    CL6' '                                                   19320000
         TITLE 'APL UTILITY MAGNETIC TAPE WRITE               05/11/70' 19380000
         SPACE                                                          19440000
*                                                                       19500000
*        WRITE WORKSPACE SPECIFIED BY R 11 TO MAG TAPE.                 19560000
*                                                                       19620000
TWRITE   EQU   1                                                        19680000
         SPACE                                                          19740000
         ENTRY MTWR                                                     19800000
MTWR     PROLOG MTSAVAR,MTSAVR1Z                                        19860000
         ST    1,MTSAVR1                                                19920000
         MVC   MTWSLIB(16),WFLLIB  SAVE WSID FOR THIS RECORD            19980000
         MVC   MTWSDATE(12),WFLDATE  SAVE TIME STAMP FOR THIS RECORD    20040000
         L     1,=A(UTFLAGS)       MAKE SURE HE WANTS ALL WSID          20100000
         TM    0(1),UTWSLST          LISTED BEFORE DOING SO.            20160000
         BZ    MTWRX                                                    20220000
         MVC   DISWSID(6),=CL6'      ' BLANK OUT POSSIBLE ERROR PFX     20280000
         ICALL OUTWRT              LIST WSID & TIME STAMP               20340000
         DC    AL4(MTWSID)                                              20400000
MTWRX    ICALL MTWRZ               CLEAN UP ANY PREVIOUS WRITE          20460000
         MVI   TOP,TWRITE          OPERATION FOR CTCOMP                 20520000
         ICALL CTCOMP              SET UP TAPE CCW CHAIN.               20580000
         TM    MTFLAGS,MTREJ       THIS TEST SHOULD BE UNNECESSARY      20640000
         BO    MTWRXX              SINCE MX, SVI WERE CHECKED BY CDCOMP 20700000
*                                  WHEN WS WAS READ FROM DISK.          20760000
         MVC   MTDCCB+8(4),=A(TCCWAR)  CCB CCW ADDRESS                  20820000
         EXCP  MTDCCB              START THE WRITE.                     20880000
         OI    MTFLAGS,CCWAIU      MARK I/O PENDING.                    20940000
MTWRXX   NI    MTFLAGS,255-MTREJ   TURN OFF REJECT FLAGS                21000000
         L     1,MTSAVR1                                                21060000
         IRETURN                                                        21120000
         TITLE 'APL UTILITY MAGNETIC TAPE END OF WRITE        05/11/70' 21180000
*                                                                       21240000
*        END OF WRITE AND END OF VOLUME ROUTINE.                        21300000
*                                                                       21360000
         ENTRY MTWRZ                                                    21420000
MTWRZ    PROLOG MTSAVAR,MTSAVR5Z                                        21480000
         STM   0,4,MTSAVR1                                              21540000
         TM    MTFLAGS,CCWAIU      CHECK FOR PENDING I/O.               21600000
         BZ    MTWRZZ              BRANCH IF NONE.                      21660000
MTWRZ2   WAIT  MTDCCB              WAIT FOR COMPLETION                  21720000
         TM    MTDCCB+4,UE         CHECK FOR END OF VOLUME.             21780000
         BO    MTWEOV              BRANCH IF SO.                        21840000
         CLC   MTDCCB+13(3),EXPCSWA+1 CHECK FINAL CSW ADDRESS.          21900000
         BE    MTWRZZ              OK                              3066 21960000
         MVC   TAPEUNIT(3),LOGUN   TAPE ADDRESS TO MSG             3066 22020000
         ICALL OUTWRTL             PERMANENT I/O ERROR- WRITE MSG  3066 22080000
         DC    AL4(TAPERROR)                                       3066 22140000
         CANCEL ,                  ABEND                           3066 22200000
MTWRZZ   NI    MTFLAGS,255-CCWAIU                                       22260000
         LM    0,4,MTSAVR1                                              22320000
         IRETURN                                                        22380000
*                                                                       22440000
*        END OF VOLUME                                                  22500000
*                                                                       22560000
*        TO AVOID WRITING OFF THE END OF A REEL OF TAPE, WE OPEN A      22620000
*        NEW REEL AND WRITE THE ENTIRE WS THERE.  MTRDZ WILL REJECT     22680000
*        THE INCOMPLETE COPY WHICH CONTAINS THE TAPE MARK.              22740000
*                                                                       22800000
MTWEOV   TM    MTFLAGS,CLOSING     SEE IF CALL WAS FROM MTCLOSE         22860000
         BO    MTWRZZ                                                   22920000
         MVC   MTLABAR(3),=C'EOV'  SET UP EOV LABEL.                    22980000
         LA    4,MTTRLBL           WRITE EOV LABEL & SHOW OPERATOR      23040000
         BALR  3,4                                                      23100000
         ICALL MTWOPEN             OPEN NEW VOLUME.                     23160000
         CLC   MTDCCB+13(3),EXPCSWA+1  CHECK FOR COMPLETION             23220000
         BE    MTWRZZ                                                   23280000
         MVC   MTDCCB+8(4),=A(TCCWAR)  MOVE CCW START ADDR TO CCB       23340000
         EXCP  MTDCCB              WRITE THE WS AGAIN                   23400000
         B     MTWRZ2              GO ACT AS IF NOTHING HAPPENED        23460000
         DROP  PR                                                       23520000
*                                                                       23580000
*        WRITE EOF OR EOV LABEL & SHOW OPERATOR                         23640000
*                                                                       23700000
         USING *,4                                                      23760000
MTTRLBL  LA    2,=AL1(WEF,NOP,TWRITE,WEF,WEF)  COMMANDS                 24180000
         LA    0,5                 SET COMMAND COUNT                    24300000
         LA    1,CTLCCB                                                 24360000
MTTRLBL1 MVC   CTLCCW(1),0(2)      PLANT CCW COMMAND                    24420000
         EXCP  (1)                                                      24480000
         WAIT  (1)                                                      24540000
         LA    2,1(2)              NEXT COMMAND PLEASE                  24600000
         BCT   0,MTTRLBL1                                               24660000
         ICALL LOGMTLAB                                                 24720000
         L     2,DCBCUR                                                 24900000
         CLOSE ((2))               CLOSE TAPE DCB AT EOF OR EOV         24960000
         BR    3                   RETURN                               25020000
         DROP  4                                                        25080000
         TITLE 'APL UTILITY MAGNETIC TAPE INPUT OPEN          05/11/70' 25140000
*                                                                       25200000
*        INPUT TAPE LABEL CHECKING                                      25260000
*                                                                       25320000
         ENTRY MTROPEN                                                  25380000
MTROPEN PROLOG MTSAVAR,MTREPZ                                           25440000
         STM   1,2,MTSAVR1                                              25500000
         NI    MTFLAGS,255-MTEOF                                        25560000
         XC    MTLABAR(80),MTLABAR                                      25620000
         TM    MTFLAGS,FILOPEN     CHECK FOR FIRST REEL.                25680000
         BO    MTRO1               BRANCH IF NOT.                       25740000
         MVI   CTCOMP2+1,0         SET FIRST TIME SWITCH (SIGH)  $$$$$  25800000
         MVI   MTRDZ6+1,0          SET FIRST TIME SWITCH (SIGH)  $$$$$  25860000
         MVI   MTRDZ5+1,X'F0'      SAME                                 25920000
         SETLU                     INITIALIZE LOGICAL UNITS.            25980000
MTRO1    SWITCH                    ,SWITCH LOGICAL UNITS.               26040000
         MVC   VOLID(6),=C'*NOLBL'     VOLID FOR UNLABELED TAPE         26100000
         L     2,DCBCUR                                                 26280000
         OPEN  ((2),(INPUT))                                            26340000
         TM    DCBOFLGS(2),X'10'   WAS OPEN SUCCESSFUL ?           6020 26400000
         BO    MTRO3          YES IT WAS                           6020 26460000
         ABEND 1550,DUMP                                           6020 26520000
MTRO3    MVI   CTLCCW,REW          REWIND INPUT TAPE.                   26640000
         EXCP  CTLCCB                                                   26700000
         WAIT  (1)                                                      26760000
         MVI   CTLCCW,TREAD        READ HEADER LABEL.                   26820000
MTRO2    EXCP  (1)                                                      26880000
         WAIT  (1)                                                      26940000
         LA    2,MTLABAR           LABEL AREA.                          27000000
         USING TFLAB,2                                                  27060000
         CLC   TFTYPE(3),=C'VOL'   SKIP OVER ANY VOL LABELS.            27120000
         BE    MTRVOL                                                   27180000
         CLC   TFTYPE(4),=C'HDR1'  MUST BE HEADER 1 LABEL               27240000
         BNE   MTROXXX             BRANCH IF NOT.                       27300000
         TM    MTFLAGS,FILOPEN     CHECK FOR FIRST REEL                 27360000
         BO    MTROC               BRANCH IF NOT                        27420000
         CLC   TFVSEQ+2(2),=C'01'  REALLY VOL 1                         27480000
         BNE   MTRVSER             NO, ERROR                            27540000
MTROCI   MVC   MTROCD(6),TFCDAT    SAVE CREATION DATE &                 27600000
         MVC   MTRPVS(2),TFVSEQ+2    VOLUME SEQUENCE NUMBER             27660000
MTROVI   TR    MTRPVS+1(1),EBCDEC  ADD ONE TO VOL SEQ NUMBER            27720000
         CLI   MTRPVS+1,C'0'       CHECK FOR OVERFLOW                   27780000
         BNE   MTR04                                                    27840000
         TR    MTRPVS(1),EBCDEC    99 ENOUGH FOR ANYBODY                27900000
MTR04    CLC   TFFID,APLMTID       CHECK FOR APL DUMP ID                27960000
         BNE   MTROXXY             REFUSE IT IF NOT OURS                28020000
         MVC   TRECLEN(4),TFBLKCT  PICK UP RECORD LENGTH FROM LABEL.    28080000
         EXCP  CTLCCB              POSITION OVER TAPE MARK              28140000
         WAIT  (1)                                                      28200000
         TM    CTLCCB+4,UE         IF WE DIDN'T SKIP OVER TAPE MARK,    28260000
         BZ    MTROXXX               TAPE NOT TO OUR STANDARDS,REJECT.  28320000
         OI    MTFLAGS,FILOPEN     MARK FILE AS OPEN.                   28380000
         ICALL LOGMTLAB            LOG HEADER LABEL                     28440000
         LM    1,2,MTSAVR1                                              28500000
         IRETURN                                                        28560000
*                                                                       28620000
MTRVOL   CLI   TFNUM,C'1'          IGNORE ALL BUT VOL1 LABELS           28680000
         BNE   MTRO2                                                    28740000
         MVC   VOLID(6),TFFID      SAVE VOLID                           28800000
         B     MTRO2                                                    28860000
*                                                                       28920000
MTROC    CLC   MTROCD(6),TFCDAT    CHECK FOR CONSISTENT CREATION DATE   28980000
         BNE   MTRVSER               IF NOT, ERROR                      29040000
         CLC   MTRPVS(2),TFVSEQ+2  ERROR IF SEQUENCE NUMBER IS NOT      29100000
         BE    MTROVI              ONE MORE THAN PREVIOUS               29160000
*              VOLUME SEQUENCE ERROR MESSAGE & OPERATOR COMMUNICATION   29220000
MTRVSER  ICALL LOGMTLAB            SHOW THE LABEL TO THE OPERATOR       29280000
         ICALL OUTWRTL             WRITE VOL SEQ ERR MESSAGE TO OPR     29340000
         DC    AL4(SEQMSG)                                              29400000
MTRVSERX LA    1,MTREP             POINT TO REPLY AREA                  29460000
         LR    0,1                 R0 NOT = 0 MEANS SYSLOG              29520000
         ICALL OUTWRTL                                                  29580000
         DC    AL4(REPMSG)                                              29640000
         OC    MTREP(7),=CL7' '    FOLD TO UPPER CASE                   29700000
         CLC   MTREP(6),=C'IGNORE' DOES HE REALLY WANT THIS TAPE        29760000
         BE    MTROCI              YES, HE'S THE BOSS                   29820000
         CLC   MTREP(7),=C'NEWTAPE' DID HE PUT UP THE WRONG TAPE        29880000
         BE    MTRO3               YES, PROCESS LABEL.                  29940000
         B     MTRVSERX                                                 30000000
*                                                                       30060000
MTROXXY  ICALL LOGMTLAB                                                 30120000
MTROXXX  ICALL OUTWRTL             COMPLAIN TO THE OPERATOR             30180000
         DC    AL4(XXXMSG)                                              30240000
         MVI   CTLCCW,RUN          UNLOAD THE REJECTED TAPE.            30300000
         EXCP  CTLCCB                                                   30360000
         WAIT  (1)                                                      30420000
         B     MTRO3                                                    30480000
         DROP  2                                                        30540000
         TITLE 'APL UTILITY MAGNETIC TAPE READ                05/11/70' 30600000
*                                                                       30660000
*        READ A WORKSPACE FROM TAPE TO THE AREA SPECIFIED BY R 11.      30720000
*                                                                       30780000
TREAD    EQU   2                                                        30840000
         ENTRY MTRD                                                     30900000
MTRD     PROLOG MTSAVAR,MTSAVR2Z                                        30960000
         STM   1,2,MTSAVR1                                              31020000
         ICALL MTRDZ               OTHERWISE, COMPLETE.                 31080000
MTR1     MVI   MTRRTCT,0           SET READ RETRY COUNT TO 0            31140000
         MVI   MTR6+1,0            SET RETRY SWITCH. (PROG MOD)         31200000
         L     1,=A(TCCWAR)        SET UP READ OF FIRST RECORD.         31260000
         ST    11,0(1)             DATA ADDRESS.                        31320000
         MVI   0(1),TREAD          COMMAND.                             31380000
         MVC   4(4,1),=A(SVI-M+4)  ZERO FLAGS, COUNT.                   31440000
         MVC   MTDCCB+8(4),=A(TCCWAR)                                   31500000
MTR1A    EXCP  MTDCCB              READ FIRST RECORD.                   31560000
         WAIT  (1)                                                      31620000
         NI    MTFLAGS,255-MTREJ-SIZEMOD   RESET FLAGS                  31680000
         TM    MTDCCB+4,UE         CHECK FOR EOF.                       31740000
         BZ    MTR1B                                                    31800000
         ICALL MTREOF              PROCESS END OF VOLUME                31860000
         TM    MTFLAGS,MTEOF       IF NOT EOF, REREAD WS FROM NEXT TAPE 31920000
         BO    MTR5                                                     31980000
         B     MTR1                                                     32040000
MTR1B    TM    MTDCCB+5,IL         CHECK FOR INCORRECT LENGTH           32100000
         BNZ   MTR6                                                     32160000
         TM    MTDCCB+2,UNERR      LOOK FOR UNRECOVERABLE DATA CHECK    32220000
         BZ    MTR3                NO ERRORS                            32280000
         B     MTR6A                                                    32340000
*                                                                       32400000
*        INCORRECT LENGTH ON FIRST RECORD.                              32460000
*                                                                       32520000
MTR6     BC    0,MTR1A             PROGRAM MODIFIED  $$$$$$$$$$$        32580000
         MVI   CTLCCW,BSR          OTHERWISE, RETRY.                    32640000
         EXCP  CTLCCB              BACKSPACE RECORD.                    32700000
         WAIT  (1)                                                      32760000
         TR    MTRRTCT,MTRRTR      COUNT RETRIES.                       32820000
         CLI   MTRRTCT,0           SEE IF WE'VE EXHAUSTED LIMIT.        32880000
         BNE   MTR1A               NO, WE CAN RETRY THE READ.           32940000
*        AFTER 4 RETRIES, STILL GET INCORRECT LENGTH.                   33000000
MTR6A    BAL   2,SHOWDIS           TELL OPR WE MAY HAVE LOST A WS       33060000
         MVI   MTR6+1,X'F0'        FLIP RETRY SWITCH SO WE'LL FORWARD   33120000
*                                  SPACE.                               33180000
         B     MTR1A               AND GO PROCEED TO SPACE TAPE.        33240000
*                                                                       33300000
*        FIRST RECORD WAS READ SUCESSFUL.  PROCEED TO READ REST OF WS.  33360000
*                                                                       33420000
MTR3     MVI   TOP,TREAD           OPERATION FOR CTCOMP.                33480000
         ICALL CTCOMP              COMPUTE CCW CHAIN.                   33540000
         OI    MTFLAGS,CCWAIU      MARK CCW AREA IN USE                 33600000
         TM    MTFLAGS,MTREJ       AVOID MESSAGE IF CTCOMP OK'ED THE WS 33660000
         BZ    MTR4                                                     33720000
         TM    MTFLAGS,SIZEMOD     IF WS SIZE IS BEING CONVERTED,       33780000
         BO    MTR4                WE'LL WORRY ABOUT ERROR AT MTRDZ.    33840000
         BAL   2,SHOWDIS           TELL OPR THINGS DON'T LOOK GOOD      33900000
         B     MTR5                                                     33960000
MTR4     MVC   MTDCCB+8(4),=A(TCCWAR+8)  IGNORE THE FIRST CCW           34020000
         L     1,=A(TCCWAR+8)      RESET SKIP BIT IN SECOND CCW,        34080000
         NI    4(1),255-SKIP       WHICH IS SET WHEN WS TOO BIG.        34140000
*                                  (WE NEED 2ND RECORD FOR WSID)        34200000
         EXCP  MTDCCB              START THE I/O.                       34260000
MTR5     LM    1,2,MTSAVR1                                              34320000
         IRETURN                                                        34380000
         TITLE 'APL UTILITY MAGNETIC TAPE END OF READ'                  34440000
*                                                                       34500000
*        COMPLETION OF MAG TAPE READ OPERATION.                         34560000
*                                                                       34620000
         ENTRY MTRDZ                                                    34680000
MTRDZ    PROLOG MTSAVAR,MTSAVRBZ                                        34740000
         STM   1,2,MTSAVR1                                              34800000
         ST    11,MTSAVRB                                               34860000
         TM    MTFLAGS,CCWAIU      CHECK FOR ANYTHING PENDING.          34920000
         BZ    MTRDZZ              BRANCH IF NONE.                      34980000
         TM    MTFLAGS,SIZEMOD     IF MTREJ BUT NOT SIZEMOD BY CTCOMP,  35040000
         BO    MTRDZ1              (SEE NOTE IN CTCOMP) WE SHOULD       35100000
         TM    MTFLAGS,MTREJ       RETURN WITH MTREJ SET, AND NEXT      35160000
         BO    MTRDZZ              READ SHOULD BE SUCESSFUL.            35220000
MTRDZ1   WAIT  MTDCCB              WAIT FOR COMPLETION.                 35280000
         L     11,=A(TCCWAR)       GET ADDRESS OF WS                    35340000
         L     11,0(11)                                                 35400000
         LA    11,0(11)                                                 35460000
         TM    MTDCCB+4,UE         IF TAPE MARK WAS READ BEFORE END     35520000
         BZ    MTRDZNE             OF WS, QUIETLY IGNORE THIS COPY,     35580000
         ICALL MTREOF              SINCE THE COMPLETE COPY OF THIS WS   35640000
         OI    MTFLAGS,MTREJ       IS ON THE NEXT REEL.                 35700000
         B     MTRDZZ                                                   35760000
MTRDZNE  TM    MTDCCB+2,UNERR                                           35820000
         BO    MTRDIS              UNRECOVERABLE READ ERROR             35880000
         TM    MTDCCB+5,IL         INCORRECT LENGTH HAS SPECIAL CASES   35940000
         BZ    MTRDZ2              BRANCH IF NOT.                       36000000
         MVC   MTTEMP(4),MTDCCB+12  OTHERWISE, CHECK FOR A DC CCW.      36060000
         L     1,MTTEMP                                                 36120000
         S     1,=F'16'                                                 36180000
         TM    4(1),DC                                                  36240000
         BZ    MTRDZ4                                                   36300000
         LA    1,8(1)              OTHERWISE,                           36360000
         CLC   MTDCCB(2),6(1)      RESIDUAL COUNT MUST EQUAL COUNT OF   36420000
         BNE   MTRDZ4              CCW AFTER DC CCW, ELSE TAPE ERROR    36480000
         MVI   0(1),TREAD          FORCE COMMAND TO A READ.             36540000
         ST    1,MTTEMP                                                 36600000
         MVC   MTDCCB+9(3),MTTEMP+1  RESUME CHAIN BACK 1 CCW            36660000
         EXCP  MTDCCB                                                   36720000
         B     MTRDZ1              WAIT FOR COMPLETION.                 36780000
MTRDZ2   CLC   MTDCCB+13(3),EXPCSWA+1  CHECK CSW ADDRESS.               36840000
         BNE   MTRDIS              BRANCH IF NOT THE EXPECTED.          36900000
*                                                                       36960000
*        PERFORM WORKSPACE SIZE RELOCATION IF REQUIRED                  37020000
*                                                                       37080000
         TM    MTFLAGS,MTREJ+SIZEMOD   IF WS TOO LARGE, REJECT          37140000
         BO    MTRDZ6                                                   37200000
         TM    MTFLAGS,SIZEMOD     IF WS SIZE RELOCATION REQUIRED,      37260000
         BZ    MTRDZ8                                                   37320000
         ICALL RELOCWS             GO RELOCATE WS                       37380000
         TM    MTFLAGS,MTREJ       IF WS WAS REJECTED, WE'RE DONE       37440000
         BO    MTRDZZ                                                   37500000
*                                                                       37560000
*        PERFORM WORKSPACE MODIFICATION IF REQUESTED (APLMOD)           37620000
*                                                                       37680000
MTRDZ8   L     1,=A(CMD)           SEE IF WSS ARE BEING MODIFIED        37740000
         TM    0(1),CMMOD                                               37800000
CMMOD    EQU   X'10'               CMD MASK - CALL APLMOD ROUTINE       37860000
         BZ    MTRDZX              BRANCH IF NO MODIFICATIONS           37920000
         L     1,=A(APLMODAD)      MODIFICATION PROGRAM ADDRESS.        37980000
         L     1,0(1)                                                   38040000
         BALR  LKR,1                                                    38100000
MTRDZX   MVC   MTWSLIB(16),WFLLIB  SAVE WSID FOR THIS RECORD            38160000
         MVC   MTWSDATE(12),WFLDATE SAVE TIME STAMP FOR THIS RECORD     38220000
MTRDZ5   BC    15,MTRDZY           PROGRAM MODIFIED $$$$$$$$$$$$$$$$$$  38280000
         MVC   DISWSID(6),=CL6'BEFORE'  SHOW WHERE WE RECOVERED FROM    38340000
         ICALL OUTWRT              THE LAST READ ERROR                  38400000
         DC    AL4(DISWSID)                                             38460000
         MVI   MTRDZ5+1,X'F0'      RESTORE TO NORMAL (NO PRIOR ERROR)   38520000
MTRDZY   L     11,MTSAVRB                                               38580000
MTRDZZ   NI    MTFLAGS,255-CCWAIU  TURN OFF PENDING FLAG.               38640000
         LM    1,2,MTSAVR1                                              38700000
         IRETURN                                                        38760000
*                                                                       38820000
*        REJECT A WS WHICH IS TOO BIG FOR THIS SYSTEM                   38880000
*                                                                       38940000
MTRDZ6   BC    0,MTRDZ7            FIRST PASS SWITCH (MODIFIED) $$$$$$  39000000
         ICALL OUTWRTL             TELL THE OPERATOR WE ARE REJECTING   39060000
         DC    AL4(SIZEMSG2)       WS(S) AS BEING TOO BIG.              39120000
         MVI   MTRDZ6+1,X'F0'      RESET 1ST PASS SWITCH  $$$$$$$$$$$$  39180000
MTRDZ7   MVC   SIZEWSID(16),WFLLIB LOG TO SYSLST THE TIME STAMP AND     39240000
         MVC   SIZEDATE(12),WFLDATE  WSID OF EACH WS WE ARE REJECTING   39300000
         ICALL OUTWRT                AS TOO BIG.                        39360000
         DC    AL4(SIZEMSG3)                                            39420000
         B     MTRDZY                                                   39480000
*                                                                       39540000
*        INCORRECT LENGTH ERROR ON CCW NOT DATA-CHAINED                 39600000
*                                                                       39660000
MTRDZ4   MVI   CTLCCW,BSR          BACKUP AND ASSUME NOISE CAUSED       39720000
         EXCP  CTLCCB              US TO READ INTO NEXT WS.             39780000
*                                                                       39840000
*        CAN'T MAKE SENSE OUT OF THIS SPOT ON TAPE.                     39900000
*        TELL THE OPERATOR WE THINK WE'VE LOST A WORKSPACE, AND         39960000
*        THEN TRY TO POSITION TO THE NEXT GOOD WORKSPACE ON TAPE.       40020000
*                                                                       40080000
MTRDIS   BAL   2,SHOWDIS           TELL THE OPERATOR WE ARE GIVING UP   40140000
         MVC   DISWSID(6),=CL6'ERROR '  WE MIGHT AS WELL TRY TO SHOW    40200000
*                                  HIM THE WSID FOR THIS WS.            40260000
         MVC   MTWSLIB(16),WFLLIB  SAVE WSID FOR THIS RECORD            40320000
         MVC   MTWSDATE(12),WFLDATE SAVE TIME STAMP FOR THIS RECORD     40380000
         ICALL OUTWRT                                                   40440000
         DC    AL4(DISWSID)                                             40500000
         OI    MTFLAGS,MTREJ                                            40560000
         MVC   MTDCCB+8(4),=A(TCCWAR)                                   40620000
         L     1,=A(TCCWAR)        SET UP A READ WITH SKIP.             40680000
         MVC   0(8,1),MTS1CW       SKIP CCW.                            40740000
MTRDIS1  EXCP  MTDCCB              READ WITH SKIP.                      40800000
         WAIT  (1)                                                      40860000
         TM    MTDCCB+4,UE         SEE IF WE HIT AN END FILE.           40920000
         BO    MTRDISZ             QUIT IF SO.                          40980000
         TM    MTDCCB+5,IL         CHECK FOR INCORRECT LENGTH.          41040000
         BO    MTRDIS1             SKIP ANOTHER RECORD IF SO.           41100000
MTRDISZ  MVI   CTLCCW,BSR          SET UP BACKSPACE RECORD.             41160000
         EXCP  CTLCCB              BACKSPACE OVER LAST RECORD.          41220000
         B     MTRDZY                                                   41280000
MTRRTCT  DC    X'00'                                                    41340000
MTRRTR   DC    X'0102030400'                                            41400000
         TITLE 'APL UTILITY MAGNETIC TAPE INPUT CLOSE         05/11/70' 41460000
*                                                                       41520000
*        INPUT TAPE CLOSE ROUTINE.                                      41580000
         ENTRY MTRCLOSE                                                 41640000
MTRCLOSE PROLOG MTSAVAR,MTSAVR1Z                                        41700000
         ST    1,MTSAVR1                                                41760000
         L     5,DCBCUR                                                 42180000
         CLOSE ((5))                                                    42240000
         MVI   MTFLAGS,MTEOF       CLEAR FLAGS                          42300000
         L     1,MTSAVR1                                                42360000
         IRETURN                                                        42420000
*                                                                       42480000
*        END OF FILE ON INPUT TAPE                                      42540000
*                                                                       42600000
MTREOF   PROLOG                                                         42660000
         MVI   CTLCCW,TREAD        READ TRAILER LABEL                   42720000
         EXCP  CTLCCB                                                   42780000
         WAIT  (1)                                                      42840000
         CLC   MTLABAR(3),=C'EOF'  CHECK FOR LAST REEL                  43200000
         BNE   MTREOF1                                                  43260000
MTREOF0  MVI   MTFLAGS,MTEOF       SET END-OF-FILE, RESETTING ALL ELSE  43320000
         ICALL LOGMTLAB                                                 43380000
         B     MTREOFZ                                                  43440000
MTREOF1  CLC   MTLABAR(3),=C'EOV'  VERIFY END OF VOLUME                 43500000
         BE    MTREOF2                                                  43560000
         MVC   MTLABAR(21),=C'****NO TRAILER LABEL '                    43620000
         B     MTREOF0             TREAT LIKE AN EOF ANYWAY             43680000
MTREOF2  ICALL LOGMTLAB                                                 43740000
         ICALL MTROPEN             OPEN NEXT FILE                       43800000
MTREOFZ  IRETURN ,                 RETURN                               43860000
         DROP  12                                                       43920000
*                                                                       43980000
*        SHOWDIS TELLS THE OPERATOR WE ARE REJECTING A WS & THE WSID    44040000
*        OF THE PRIOR WS. IT THEN INDICATES THAT THE NEXT SUCESSFUL     44100000
*        WS READ SHOULD ALSO BE LOGGED.                                 44160000
*                                                                       44220000
SHOWDIS  BALR  1,0                                                      44280000
         USING *,1                                                      44340000
         L     1,=A(MTRDZ)                                              44400000
         USING MTRDZ,1                                                  44460000
         ICALL OUTWRTL             TELL THE OPERATOR                    44520000
         DC    AL4(DISMSG)                                              44580000
         MVC   DISWSID(6),=CL6'AFTER '  SHOW LAST WSID                  44640000
         ICALL OUTWRT                                                   44700000
         DC    AL4(DISWSID)                                             44760000
         MVI   MTRDZ5+1,X'00'      REMEMBER TO SHOW NEXT WSID $$$$$$$   44820000
         BR    2                   RETURN                               44880000
         DROP  1                                                        44940000
         TITLE 'APL UTILITY MAGNETIC TAPE CCW GENERATION      05/11/70' 45000000
*                                                                       45060000
*        MAGNETIC TAPE CCW GENERATION                                   45120000
*                                                                       45180000
*        EACH WS ON TAPE CONSISTS OF 3 OR MORE PHYSICAL RECORDS LE      45240000
*        RECLEN.  THE WS IS WRITTEN AS TWO AREAS, FROM START OF WS      45300000
*        THRU MX, AND FROM SVI THRU END OF WS, WITH A LITTLE SLACK      45360000
*        AT EACH END. THIS FORMAT MINIMIZES THE AMOUNT OF TAPE          45420000
*        REQUIRED FOR EACH WS.                                          45480000
*                                                                       45540000
*        RECORD 1 IS FROM THE START OF WS THRU INCLUSIVE THE LOCATIONS  45600000
*        QR13STK, MX & SVI.  FROM THESE THREE LOCATIONS WE CAN          45660000
*        COMPUTE THE WSLEN ON TAPE TO DETERMINE IF RELOCATION IS        45720000
*        REQUIRED, AND ALSO GENERATE THE APPROPRIATE CCW CHAIN.         45780000
*        AREA 1 CONTINUES THRU MX, AREA 2 STARTS AT SVI THRU THE END    45840000
*        OF THE WS.                                                     45900000
*                                                                       45960000
*        THE TAPE ERROR RETRY LOGIC AT MTRDIS INTRODUCES THE VERY       46020000
*        SLIGHT POSSIBILITY THAT THE RECORD WE CURRENTLY THINK IS THE   46080000
*        FIRST RECORD OF THIS BLOCK IS REALLY THE LAST RECORD OF THE    46140000
*        DISCARDED WS.  TO PROTECT OURSELVES FROM DISASTER, WE MAKE     46200000
*        EFFECTIVELY THE SAME TESTS ON MX & SVI WHICH ARE MADE IN       46260000
*        CDCOMP (& A FEW OTHERS FOR GOOD MEASURE).  WE CANNOT DO THINGS 46320000
*        EXACTLY THE SAME WAY CDCOMP DOES, BECAUSE WE MUST ALSO         46380000
*        RECOGNIZE AND HANDLE WS SIZE ADJUSTMENT.                       46440000
*                                                                       46500000
*        NOTE:  IT WOULD BE DESIRABLE TO DATA CHAIN BETWEEN MX & SVI,   46560000
*        AND THE CCW'S ARE GENERATED TO ALLOW FOR THIS POSSIBILITY.     46620000
*              IN OS WE CANNOT SAFELY DO THIS FOR EITHER TAPE READS     47280000
*        OR WRITES.  THEREFORE WE ARE UNABLE TO PROCESS ANY TAPES       47340000
*        WRITTEN WITH DATA CHAINING                                     47400000
*                                                                       47520000
*        TO IMPLEMENT DATA CHAINING OF WRITES ON A SYSTEM WHICH         47580000
*        SUPPORTS CCW RETRY CORRECTLY, CHANGE THE INSTRUCTION AT        47640000
*        CTCOMP0 TO   MVI DCF,SLI+DC                                    47700000
*                                                                       47760000
*        R 11  -  MR.                                                   47820000
*        R 10  --  CURRENT WS POINTER                                   47880000
*        R 9  -  CCW POINTER                                            47940000
*        R 7  -  MX                                                     48000000
*        R 8  -  SVI                                                    48060000
*        R 6  -  RECORD LENGTH                                          48120000
*                                                                       48180000
DC       EQU   X'80'                                                    48240000
CC       EQU   X'40'                                                    48300000
SLI      EQU   X'20'                                                    48360000
SKIP     EQU   X'10'                                                    48420000
*                                                                       48480000
CTCOMP   PROLOG CTSAVAR,CTSAVARZ                                        48540000
         STM   0,10,CTREGSV                                             48600000
         SPACE                                                          48660000
         MVI   CCF,CC              SET UP CCW FLAGS.                    48720000
         MVI   DCF,CC              CC FOR OS ON READ                    49020000
         CLI   TOP,TWRITE          SEE IF THIS IS A WRITE.              49140000
         BNE   CTCOMP1             BRANCH IF NOT.                       49200000
         MVI   CCF,SLI+CC          OTHERWISE, SUPRESS INCORRECT LENGTH  49260000
CTCOMP0  MVI   DCF,SLI+CC          WHICH WILL ALWAYS OCCUR ON WRITE.    49320000
*                                  WE DON'T DARE DATA CHAIN (SEE NOTE)  49380000
CTCOMP1  LR    10,MR               MOVE WS POINTER TO R10.              49440000
         L     9,=A(TCCWAR)        GET ADDRESS OF CCW AREA.             49500000
*                                                                       49560000
*                    R5       R6    R7 R8                               49620000
         LM    5,8,QR13STK ,QSYMBOT,MX,SVI                              49680000
         CR    7,8                 IF MX IS GREATER THAN SVI, EVIL      49740000
         BH    CTCOMPXX                                                 49800000
         LTR   7,7                 IF MX IS NEGATIVE, EVIL              49860000
         BNH   CTCOMPXX                                                 49920000
         CR    8,6                 IF SVI GREATER THAN QSYMBOT, EVIL    49980000
         BH    CTCOMPXX                                                 50040000
         L     2,=A(WSLEN)         PICK UP WS LENGTH (CORE)             50100000
         L     2,0(2)                                                   50160000
         ST    2,WLEN              SAVE IN CASE NEEDED                  50220000
         S     2,=A(LR13STK)       SUBTRACT R13 STACK LENGTH            50280000
         SR    2,5                 COMPUTE DIFFERENCE BETWEEN CORE      50340000
         BZ    CTCOMP4             & TAPE WS LENGTH. IF SAME, EASY.     50400000
*                                                                       50460000
*        WS SIZE RELOCATION IS REQUIRED                                 50520000
*                                                                       50580000
         CLI   TOP,TWRITE          IF WE ARE DOING A WRITE & WSLEN      50640000
         BE    CTCOMPXX            INCORRECT, THINGS LOOK VERY BAD      50700000
CTCOMP2  BC    0,CTCOMP3           NOTIFY OPR 1ST TIME (PROG MOD) $$$$  50760000
         LA    3,LR13STK(5)        COMPUTE TAPE WS LENGTH               50820000
         ST    3,SIZETAPE                                               50880000
         ICALL OUTWRTL             TELL OPERATOR WS SIZE ADJUSTMENTS IN 50940000
         DC    AL4(SIZEMSG1)         PROGRESS                           51000000
         MVI   CTCOMP2+1,X'F0'     ONLY 1ST TIME (PROG MODIF)  $$$$$$$  51060000
CTCOMP3  OI    MTFLAGS,SIZEMOD     INDICATE WS SIZE ADJ FOR THIS WS     51120000
         ST    2,RELFACT           SAVE RELOCATION FACTOR FOR LATER     51180000
         AR    5,2                 ADJUST QR13STK                       51240000
         AR    6,2                 ADJUST QSYMBOT                       51300000
         AR    8,2                 ADJUST SVI                           51360000
         S     8,=F'80'            INSIST ON SLOP                       51420000
         CR    7,8                 IF MX IS NOW GT SVI, WS IS TOO BIG   51480000
         LA    8,80(8)                                                  51540000
         BNH   CTCOMP4               AND WILL BE READ USING OLD SIZE    51600000
         OI    CCF,SKIP            & SKIP FLAG ON IN CCW                51660000
         OI    DCF,SKIP                                                 51720000
         OI    MTFLAGS,MTREJ       INDICATE WS REJECTED                 51780000
         B     CTCOMP5                                                  51840000
CTCOMP4  STM   5,8,QR13STK & ASSOCIATES                                 51900000
CTCOMP5  LA    7,7(7)              ROUND MX                             51960000
         N     7,=F'-8'            TO DOUBLE WORD BOUNDARY.             52020000
         L     6,TRECLEN           GET RECORD LENGTH                    52080000
*                                                                       52140000
*        SET UP CCW FOR FIRST RECORD                                    52200000
*        START OF WORKSPACE TO 4 + ADDRESS OF SVI                       52260000
*                                                                       52320000
         ST    10,0(9)             DATA ADDRESS.                        52380000
         MVC   0(1,9),TOP          OPERATION.                           52440000
         MVC   4(4,9),=A(SVI-M+4)  COUNT.                               52500000
         A     10,4(9)             NEW WS POINTER.                      52560000
         S     7,4(9)              REMAINING TO MX.                     52620000
         MVC   4(1,9),CCF          FLAGS - COMMAND CHAIN.               52680000
         LA    9,8(9)              9 POINTS TO NEXT CCW.                52740000
*                                                                       52800000
*        AREA 1 - 4 + ADDRESS SVI THRU MX                               52860000
*                                                                       52920000
CTCA1    ST    10,0(9)             DATA ADDRESS.                        52980000
         MVC   0(1,9),TOP          OPERATION.                           53040000
         CR    7,6                 MX VS RECORD LENGTH.                 53100000
         BL    CTCA2               FINISHED THIS AREA IF LESS.          53160000
         ST    6,4(9)              COUNT= RECORD LENGTH.                53220000
         MVC   4(1,9),CCF          FLAGS - COMMAND CHAIN.               53280000
         AR    10,6                INCREASE WS POINTER BY REC LENGTH.   53340000
         SR    7,6                 DECREMENT MXR BY REC LENGTH.         53400000
         LA    9,8(9)              POINT TO NEXT CCW.                   53460000
         B     CTCA1               ANOTHER CCW IN THIS AREA.            53520000
*                                                                       53580000
*        MXR LE RECLEN, BEGIN SECOND AREA - SVI TO END OF WS            53640000
*                                                                       53700000
CTCA2    LR    10,MR               WS ORIGIN TO R 10.                   53760000
         A     10,SVI              NEXT CCW DATA ADDRESS.               53820000
         LA    8,LR13STK                                                53880000
         A     8,QR13STK           TAPE WS LENGTH LESS SVI              53940000
         S     8,SVI               EQUALS REMAINING COUNT.              54000000
         LTR   7,7                 CHECK FOR MXR = 0                    54060000
         BZ    CTCB                                                     54120000
*                                                                       54180000
*        DATA CHAIN BETWEEN MX & SVI. (SEE NOTE ABOVE)                  54240000
*                                                                       54300000
         ST    7,4(9)              COUNT FROM MXR.                      54360000
         C     7,MINREC            CHECK FOR LESS THAN MINIMUM.         54420000
         BNL   CTCA3               RBANCH IF NOT LESS.                  54480000
         MVC   4(4,9),MINREC       OTHERWISE, USE MINIMUM COUNT.        54540000
CTCA3    MVC   4(1,9),DCF          FLAGS - DATA CHAIN (SEE NOTE ABOVE)  54600000
         LA    9,8(9)              NEXT CCW.                            54660000
         ST    10,0(9)             DATA ADDRESS.                        54720000
         MVC   0(1,9),TOP          MAKE SURE CCW HAS COMMAND CODE.      54780000
         SR    6,7                 REC LENGTH - MXR = COUNT FOR         54840000
         CR    8,6                 CHECK SVIR VS THIS COUNT.            54900000
         BNH   CTCZ                CHAIN IS COMPLETE IF LESS OR EQUAL.  54960000
         ST    6,4(9)               DATA CHAINED CCW.                   55020000
         C     6,MINREC                                                 55080000
         BNL   CTCA4                                                    55140000
         MVC   4(4,9),MINREC       MINIMUM LENGTH.                      55200000
CTCA4    S     8,4(9)              DECREMENT SVIR.                      55260000
         A     10,4(9)             INCREMENT DATA ADDRESS.              55320000
         MVC   4(1,9),CCF          FLAGS - COMMAND CHAIN.               55380000
         LA    9,8(9)              NEXT CCW.                            55440000
         L     6,TRECLEN           RELOAD RECORD LENGTH.                55500000
         SPACE                                                          55560000
*        (SVI) TO END OF WORKSPACE.                                     55620000
         SPACE                                                          55680000
CTCB     ST    10,0(9)             DATA ADDRESS.                        55740000
         MVC   0(1,9),TOP          OPERATION.                           55800000
         CR    8,6                 SVIR VS REC LENGTH.                  55860000
         BNH   CTCZ                BRANCH IF REMAINING COUNT LESS OR EQ 55920000
         ST    6,4(9)              COUNT = REC LENGTH.                  55980000
         SR    8,6                 DECREMENT REMAINING COUNT.           56040000
         AR    10,6                INCREMENT DATA ADDRESS.              56100000
         MVC   4(1,9),CCF          FLAGS - COMMAND CHAIN.               56160000
         LA    9,8(9)              INCREMENT CCW POINTER.               56220000
         B     CTCB                ANOTHER CCW, THIS AREA.              56280000
         SPACE                                                          56340000
*        FINAL CCW.                                                     56400000
         SPACE                                                          56460000
CTCZ     ST    8,4(9)              FINAL COUNT, NO FLAGS.               56520000
         C     8,MINREC                                                 56580000
         BNL   CTCZ2                                                    56640000
         MVC   4(4,9),MINREC                                            56700000
CTCZ2    MVC   4(1,9),CCF          SET FLAGS FOR POSSIBLE SLI & SKIP    56760000
         LTR   8,8                 SEE IF LAST CCW EXHAUSTED COUNT.     56820000
         BP    CTCZ1               BRANCH IF NOT.                       56880000
         S     9,=F'8'             OTHERWISE, BACK UP ONE.              56940000
CTCZ1    NI    4(9),SLI+SKIP       TURN OFF COMMAND CHAIN FLAG.         57000000
         LA    9,8(9)              EXPECTED CSW ADDRESS.                57060000
         ST    9,EXPCSWA           SAVE FOR INTERRUPT.                  57120000
         LM    0,10,CTREGSV        RESTORE ALL REGISTERS.               57180000
         IRETURN                                                        57240000
CTCOMPXX OI    MTFLAGS,MTREJ       MX AND/OR SVI INCORRECT              57300000
         B     CTCZ1               RETURN                               57360000
*                                                                       57420000
MINREC   DC    F'24'               MINIMUM RECORD LENGTH.               57480000
CCF      DC    X'00'               COMMAND CHAIN FLAG BYTE.             57540000
DCF      DC    X'00'               DATA CHAINING FLAG BYTE.             57600000
         TITLE 'APL UTILITY MAGNETIC TAPE LABEL DISPLAY       05/11/70' 57660000
LOGMTLAB PROLOG MTSAVAR,MTSAVR5Z                                        57720000
         STM   1,5,MTSAVR1                                              57780000
         LA    2,MTLABAR           LABEL AREA.                          57840000
         USING TFLAB,2                                                  57900000
         MVC   LOGLAB(4),TFTYPE    FILE TYPE.                           57960000
         MVI   LOGLAB+4,C' '                                            58020000
         MVC   LOGLAB+5(17),TFFID  FILE ID.                             58080000
         MVC   LOGVOL(6),VOLID     VOLUME ID                            58140000
         MVC   LOGREEL(2),TFVSEQ+2 REEL NUMBER.                         58200000
         MVC   LOGCDAT(7),=AL1(0,1,2,0,3,4,5)                           58260000
         TR    LOGCDAT(7),TFCDAT   CREATION DATE.                       58320000
         MVI   LOGCDAT+3,C'.'                                           58380000
         L     1,DCBCUR                                                 59580000
         L     1,44(1)             GET DEB ADDRESS                      59640000
         L     1,32(1)             GET UCB ADDRESS                      59700000
         MVC   LOGUN(3),13(1)      PUT DEVICE ADDR INTO MESSAGE         59760000
         CLI   LOGLAB,C'E'         ONLY HEADER AND GARBAGE TO SYSLOG    59820000
         BNE   LOGMTLB1                                                 59880000
         ICALL OUTWRT              OUTPUT LABEL TO SYSLST               59940000
         DC    AL4(LOGLAB)                                              60000000
         B     LOGMTLB2                                                 60060000
LOGMTLB1 ICALL OUTWRTL             OUTPUT LABEL TO SYSLOG & SYSLST      60120000
         DC    AL4(LOGLAB)                                              60180000
LOGMTLB2 LM    1,5,MTSAVR1                                              60240000
         IRETURN                                                        60300000
         DROP  2                                                        60360000
         SPACE                                                          63120000
         TITLE 'CONSTANTS AND EQUATES'                                  63180000
CTLCCB   CCB   SYS004,CTLCCW,X'8000',CTLSENSE                           63240000
         ORG   CTLCCB+12           FIX THE HIDDEN FLAG                  63300000
         DC    X'00'               USER MUST NOT MODIFY THIS BYTE.      63360000
         ORG   ,                   BUNCH OF   GRUMBLE.                  63420000
MTDCCB   CCB   SYS004,TCCWAR,X'8001'   ,FLAGS MUST NOT BE CHANGED.      63480000
CTLCCW   CCW   1,MTLABAR,X'20',80                                       63540000
MTS1CW   CCW   TREAD,TCCWAR,SKIP,SVI-M+4  SPACING CCW.                  63600000
*                                                                       63720000
DCBCUR   DC    2A(0)               ACTIVE DCB.                          63840000
SAVETEMP DS    F                                                        63900000
DCBALT   EQU   DCBCUR+4                                                 63960000
         ENTRY DCBCUR                                                   64020000
         EXTRN MTDCB4,MTDCB5,OSMTEXCP,OSMTWAIT                          64080000
         SPACE 5                                                        64200000
NOP      EQU   X'03'               NO-OP                                64260000
*        MAGNETIC TAPE COMMANDS.                                        64320000
SENSE    EQU   4                                                        64380000
REW      EQU   7                                                        64440000
RUN      EQU   15                                                       64500000
ERG      EQU   23                                                       64560000
WEF      EQU   31                                                       64620000
BSR      EQU   39                                                       64680000
BSF      EQU   47                                                       64740000
FSR      EQU   55                                                       64800000
FSF      EQU   63                                                       64860000
         SPACE                                                          64920000
UE       EQU   X'01'                                                    64980000
UC       EQU   X'02'               UNIT CHECK.                          65040000
IL       EQU   X'40'                                                    65100000
READY    EQU   X'20'                                                    65160000
RWDING   EQU   X'40'                                                    65220000
DOSHS    EQU   X'20'                                                    65280000
UNERR    EQU   X'20'                                                    65340000
UTWSLST  EQU   X'80'               UTFLAGS MASK - WSLIST                65400000
UTWSDMP  EQU   X'20'               UTFLAGS MASK - DUMP REJECTED WSS     65460000
TRECLEN  DC    F'10000'                                                 65520000
         ENTRY TRECLEN                                                  65580000
EXPCSWA  DC    A(0)                                                     65640000
MTTEMP   DC    F'0'                                                     65700000
         SPACE                                                          65760000
*        FLAG BYTE.                                                     65820000
         ENTRY MTFLAGS                                                  65880000
MTFLAGS  DC    X'00'                                                    65940000
*        SETTINGS..                                                     66000000
CCWAIU   EQU   X'80'                                                    66060000
FILOPEN  EQU   X'40'                                                    66120000
CLOSING  EQU   X'20'                                                    66180000
MTEOF    EQU   X'10'                                                    66240000
MTREJ    EQU   X'04'                                                    66300000
SIZEMOD  EQU   X'01'                                                    66360000
*                                                                       66420000
TOP      DC    X'00'               MAG TAPE OPERATION.                  66480000
         SPACE 2                                                        66900000
MTLABAR  DC    80C' '                                                   66960000
         SPACE                                                          67020000
EBCDEC   EQU   *-C'0'                                                   67080000
         DC    C'1234567890'                                            67140000
         SPACE                                                          67200000
APLHDR   DC    C'HDR1'                                                  67260000
APLMTID  DC    CL17'APL LIBRARY DUMP'                                   67320000
VOLID    DC    C'APL36000000000000301'                                  67380000
APLLR    DC    C' 993650000000'                                         67440000
         DC    CL13'APL OS VER 0'                                       67680000
         DC    CL7' '                                                   67740000
         LTORG                                                          67800000
         SPACE                                                          67860000
MTRPVS   DC    C'00'               INPUT VOL SEQ NUMBER                 67920000
MTROCD   DC    C'000000'           INPUT CREATION DATE                  67980000
*                                                                       68040000
*        OUTPUT MESSAGES.                                               68100000
*        FOR A DESCRIPTION OF THE CONTROL CODES USED, SEE OUTWRT &      68160000
*        OUTWRTL COMMENTS.                                              68220000
*                                                                       68280000
TAPERROR DC    CL30'PERMANENT WRITE ERROR ON UNIT'                 3066 68340000
TAPEUNIT DC  C'XXX-UTILITY ABORTED'                                3066 68400000
         DC    X'FF'                                               3066 68460000
MTWSID   EQU   *                   WS TIME STAMP & WSID                 68520000
DISWSID  DC    C'AFTER  '          PREFIX FOR DISASTER MESSAGE          68580000
         DC    X'13'               WS TIME STAMP & WSID                 68640000
MTWSDATE DC    12X'00'                                                  68700000
         DC    X'11'                                                    68760000
MTWSLIB  DC    16X'00'                                                  68820000
         DC    X'FF'                                                    68880000
NOHMSG   DC    C'UNABLE TO WRITE TAPE HEADER LABEL, SYS'                68940000
NOHUN    DC    X'1200FF'                                                69000000
         DS    0H                                                       69060000
LOGLAB   DC    CL23' '                                                  69120000
LOGCDAT  DC    C' YY/DDD VOLID='                                        69180000
LOGVOL   DC    C'XXXXXX '                                               69240000
         DC    C'REEL='                                                 69300000
LOGREEL  DC    C'XX UNIT='                                              69360000
LOGUN    DC    X'02FFFFFF'                                              69420000
XXXMSG   DC    C'NOT AN APL DUMP TAPE'                                  69720000
         DC    X'FF'                                                    69780000
DISMSG   DC    C'TAPE ERROR, WORKSPACE MAY HAVE BEEN LOST'              69840000
         DC    X'FF'                                                    69900000
EXPMSG   DC    C'UNEXPIRED FILE'                                        69960000
         DC    X'FF'                                                    70020000
REPMSG   EQU   *                                                        70080000
         DC    C'REPLY NEWTAPE, IGNORE OR CANCEL'                       70140000
         DC    X'FD'                                                    70200000
SEQMSG   DC    C'VOLUME SEQUENCE ERROR'                                 70260000
         DC    X'FF'                                                    70320000
RELFACT  DS    F                   RELOCATION FACTOR FOR WS SIZE RELOC  70740000
SIZEMSG1 DC    C'WORKSPACE SIZE CONVERTED FROM      '                   70800000
         DS    0F                                                       70860000
         ORG   *-5                                                      70920000
         DC    X'10'                                                    70980000
SIZETAPE DC    F'0'                WS SIZE ON TAPE                      71040000
         DC    C' BYTES TO  '                                           71100000
         DC    X'10'                                                    71160000
WLEN     DC    F'0'                WS SIZE IN CORE & DISK               71220000
         DC    X'FF'                                                    71280000
SIZEMSG2 DC    C'NAMES OF OVERSIZE WORKSPACES APPEAR ON SYSLST',X'FF'   71340000
SIZEMSG3 DC    C'WORKSPACE TOO LARGE, REJECTED '                        71400000
         DC    X'13'                                                    71460000
SIZEDATE DC    12X'00'                                                  71520000
         DC    X'11'                                                    71580000
SIZEWSID DC    16X'00'                                                  71640000
         DC    X'FF'                                                    71700000
         TITLE 'APL UTILITY MAGNETIC TAPE WS SIZE RELOCATION  05/11/70' 71760000
*                                                                       71820000
*        WS SIZE RELOCATION.                                            71880000
*                                                                       71940000
*        CTCOMP HAS RELOCATED QR13STK,QSYMBOT, AND SVI, AND HAS         72000000
*        SAVED THE RELOCATION FACTOR IN RELFACT.  THE WS WAS READ USING 72060000
*        THE RELOCATED VALUES.  WE MUST NOW RELOCATE ALL POINTERS       72120000
*        TO THE SYMBOL TABLE AND STACK.                                 72180000
*                                                                       72240000
RELOCWS  PROLOG CTSAVAR,CTSAVARZ                                        72300000
         STM   0,10,CTREGSV        SAVE REGISTERS                       72360000
         L     10,=A(RELFACT)      PRE-LOAD RELOCATION FACTOR           72420000
         L     10,0(10)                                                 72480000
*                                                                       72540000
*        RELOCATE PARREL                                                72600000
*                                                                       72660000
         L     1,PARREL            WE COULDN'T RELOCATE PARREL WHEN     72720000
         AR    1,10                WE RELOCATED ITS FRIENDS, BECAUSE    72780000
         ST    1,PARREL            PARREL IS IN RECORD 2 OF WS.         72840000
*                                                                       72900000
*        ENABLE PROGRAM CHECK ON CONDITION                              72960000
*                                                                       73020000
         SPIE  RELOCPC,((1,15))                                         73500000
*                                                                       73620000
*        IF WE HAVE A DIRECTORY, RELOCATION IS VERY SIMPLE              73680000
*                                                                       73740000
         CLC   WFLNAME,=C'APLDIRECTORY'  IF DIRECTORY, WE'RE DONE       73800000
         BE    RELO80                                                   73860000
*                                                                       73920000
*        RELOCATE ALL M-ENTRY POINTERS TO THE SYMBOL TABLE              73980000
*                                                                       74040000
         LA    4,8                                                      74100000
         LM    5,6,QR13STK ,QSYMBOT                                     74160000
         AR    5,MR                MAKE QR13STK & QSYMBOT ABSOLUTE      74220000
         AR    6,MR                                                     74280000
RELO20   LM    2,3,0(6)            LOAD M-POINTER, PRINTNAME            74340000
         CLI   4(6),3              IF SHORT PRINT NAME OR NONE,         74400000
         BNH   RELO22                LEAVE ALONE                        74460000
         L     0,M(3)              RELOCATE ST-POINTER IN PRINTNAME     74520000
         AR    0,10                                                     74580000
         ST    0,M(3)                                                   74640000
RELO22   CLC   1(3,6),=F'0'        IF MHEAD ADDR = 0, NO SYMBOL         74700000
         BE    RELO28                                                   74760000
         TM    0(6),X'80'          IF KEYWORD, DON'T RELOCATE           74820000
         BO    RELO28                                                   74880000
         L     0,M(2)                                                   74940000
         AR    0,10                RELOCATE M-ENTRY POINTER TO S.T.     75000000
         ST    0,M(2)                                                   75060000
RELO28   BXLE  6,4,RELO20          ADVANCE TO NEXT S.T. ENTRY           75120000
*                                                                       75180000
*        RELOCATE STACK ENTRIES                                         75240000
*                                                                       75300000
         L     7,=A(X'FFFFFF')                                          75360000
         L     4,PARREL                                                 75420000
         B     RELO35              SKIP THE FIRST STCODE                75480000
RELO30   LA    1,0(4,MR)           BOTH STCODE TESTS MAY NOT BE NEEDED  75540000
         CLI   STCODE(1),0         CODESTRING POINTER                   75600000
         BE    RELO35                                                   75660000
         L     1,STCODE(4,MR)      CODESTRING POINTER                   75720000
         LTR   1,1                                                      75780000
         BZ    RELO35              FREQUENTLY = 0                       75840000
         L     0,M(1)              RELOCATE MHEAD                       75900000
         AR    0,10                                                     75960000
         ST    0,M(1)                                                   76020000
RELO35   L     1,STFNSPTR(4,MR)    FN NAME BST ENTRY POINTER            76080000
         LTR   1,1                                                      76140000
         BZ    RELO31              NON-ZERO IS S.T. POINTER             76200000
         AR    1,10                  RELOCATE STFNSPTR                  76260000
         ST    1,STFNSPTR(4,MR)                                         76320000
RELO31   L     5,STFREG(4,MR)      LOAD NEXT SAVED F-REG                76380000
         LTR   5,5                                                      76440000
         BZ    RELO40              ZERO F-REG MARKS END OF CHAIN        76500000
         AR    5,10                RELOCATE F-REG                       76560000
         LA    6,0(5)                                                   76620000
         ST    5,STFREG(4,MR)                                           76680000
         LA    4,STSHADOW(4)                                            76740000
RELO32   CR    4,6                 RELOCATE IN UNIFORM FASHION          76800000
         BE    RELO30              EVERYTHING UP TO NEXT F-REG SETTING  76860000
         L     1,M(4)                                                   76920000
         LTR   1,1                                                      76980000
         BM    RELO33              INDIRECT POINTER                     77040000
         CR    1,7                                                      77100000
         BNH   RELO34              ZERO 1ST BYTE MEANS NON-POINTER      77160000
         NR    1,7                 IF ADDR = ZERO, DON'T RELOCATE       77220000
         BZ    RELO34                                                   77280000
         L     0,M(1)              RELOCATE MHEAD                       77340000
         AR    0,10                                                     77400000
         ST    0,M(1)                                                   77460000
         B     RELO34                                                   77520000
RELO33   LA    2,M(4)              DON'T RELOCATE KEYWORDS              77580000
         CLI   0(2),X'81'          RELOCATE ONLY ENTRIES WITH BYTE 0    77640000
         BH    RELO34              X'80' OR X'81' -- OTHERS ARE         77700000
*                                  (NON-POINTER) KEYWORDS               77760000
         LR    0,1                 IF ADDR = ZERO, DON'T RELOCATE       77820000
         NR    0,7                                                      77880000
         BZ    RELO34                                                   77940000
         AR    1,10                RELOCATE TO SYMBOL TABLE             78000000
         ST    1,M(4)                                                   78060000
RELO34   LA    4,4(4)                                                   78120000
         B     RELO32                                                   78180000
*                                                                       78240000
*        RELOCATE POINTERS WITHIN LISTS                                 78300000
*                                                                       78360000
RELO40   LA    4,FREE-M            START WITH FIRST M-ENTRY, IF ITS A   78420000
*                                  LIST, RELOCATE, ELSE GO TO NEXT.     78480000
RELO42   LA    5,M(4)              MAKE M-POINTER ABSOLUTE              78540000
         TM    MLIST-M(5),MLSTBIT  IF NOT A LIST, LEAVE ALONE           78600000
         BZ    RELO48                                                   78660000
         LH    3,MLSCT(4)          PICK UP NUMBER OF ENTRIES IN LIST    78720000
         LTR   3,3                 IF NULL LIST, LEAVE ALONE            78780000
         BNP   RELO48                                                   78840000
         AH    5,MLSOS(4)          ADD IN OVERHEAD                      78900000
RELO44   CLI   0(5),X'80'          RELOCATE ONLY ENTRIES WITH BYTE 0    78960000
         BL    RELO46              X'80' OR X'81' -- OTHERS ARE         79020000
         CLI   0(5),X'81'          (NON-POINTER) KEYWORDS               79080000
         BH    RELO46                                                   79140000
         L     2,0(5)                                                   79200000
         AR    2,10                RELOCATE ENTRY                       79260000
         ST    2,0(5)                                                   79320000
RELO46   LA    5,4(5)                                                   79380000
         BCT   3,RELO44            CONTINUE LOOPING UNTIL DONE          79440000
RELO48   LR    5,4                 SAVE CURR MENTRY PTR            2216 79500000
         A     4,MCOUNT(4)         JUMP TO NEXT M-ENTRY            2216 79560000
         CR    5,4                 DID WE REALLY JUMP FORWARD ?    2216 79620000
         BNL   RELOCERR            IF NOT, REJECT DAMAGED WS       2216 79680000
         C     4,MX                WHEN WE REACH MX, WE ARE DONE        79740000
         BL    RELO42                                                   79800000
*                                                                       79860000
*        RELOCATE SAVED VALUES OF REGISTERS 12 AND 13                   79920000
*                                                                       79980000
RELO80   LM    2,3,M+13*4            RELOCATE SAVED VALUES OF R13 & R14 80040000
         AR    2,10                                                     80100000
         AR    3,10                                                     80160000
         STM   2,3,M+13*4                                               80220000
*                                                                       80280000
*        DISABLE PROGRAM CHECK ON CONDITION                             80340000
*                                                                       80400000
         SPIE                                                           80760000
RELOCWSY LM    0,10,CTREGSV                                             80880000
         IRETURN  ,                RETURN TO CALLER                     80940000
*                                                                       81000000
*        REJECT A WORKSPACE AFTER A PROGRAM CHECK WHILE RELOCATING      81060000
*                                                                       81120000
RELOCERR LA    1,WFLLIB                                                 81180000
         LA    0,WFLDATE           USE COMMON MESSAGE PRINTER           81240000
         LA    2,=CL9'REJECTED '   ACTION TAKEN                     A04 81300000
         LA    3,=XL1'FF'          NO SNAP ID                           81360000
         ICALL DWSLOG                                                   81420000
         L     1,=A(MTFLAGS)       INDICATE THAT THIS WS WAS REJECTED   81480000
         OI    0(1),MTREJ                                               81540000
         B     RELOCWSY            RETURN                               82680000
*                                                                       82740000
*        PROGRAM CHECK ON-CONDITION ROUTINE                             82800000
*                                                                       82860000
         USING *,15                                                2216 83520000
RELOCPC  MVC   9(3,1),=AL3(RELOCERR)  EXIT ROUTINE ADDR TO PIE     2216 83580000
         BR    14                                                       83640000
         DROP  15                                                  2216 83700000
*                                                                       83820000
         LTORG                                                          83880000
         TITLE 'CONSTANTS AND EQUATES'                                  83940000
*                                                                       84000000
*        MAGNETIC TAPE CCW GENERATION AREA                              84060000
*                                                                       84120000
TCCWARK  EQU   200                 NUMBER OF MAGNETIC TAPE CCW'S.       84180000
*                                  MUST EQUAL TCCWARK IN DUMPSECT.      84240000
TCCWAR   DS    (TCCWARK)D                                               84300000
*                                                                       84360000
*        MAGNETIC TAPE LABEL DSECT                                      84420000
*                                                                       84480000
TFLAB    DSECT                                                          84540000
TFTYPE   DS    CL3                 HDR, EOV, EOF, OR VOL.               84600000
TFNUM    DC    CL1'1'              FILE LABEL NUMBER, EBCDIC, ALWAYS 1. 84660000
TFFID    DS    CL17                FILE IDENTIFIER.                     84720000
TFSER    DS    CL6                 FILE SERIAL NUMBER.                  84780000
TFVSEQ   DS    CL4                 VOLUME SEQUENCE NUMBER.              84840000
TFFSEQ   DS    CL4                 FILE SEQUENCE NUMBER.                84900000
TFGEN    DS    CL4                 GENERATION NUMBER.                   84960000
TFVER    DS    CL2                 VERSION NUMBER OF GENERATION.        85020000
TFCDAT   DS    CL6                 CREATION DATE.                       85080000
TFEDAT   DS    CL6                 EXPIRATION DATE.                     85140000
TFSEQ    DS    CL1                 FILE SECURITY, 0 = NONE.             85200000
TFBLKCT  DS    CL6                 BLOCK COUNT. (TRAILERS ONLY)         85260000
TFSYSCOD DC    CL13' '             SYSTEM CODE.                         85320000
TFRES    DC    CL7' '              RESERVED, SHOULD BE BLANK.           85380000
TFLABZ   EQU   *                                                        85440000
*                                                                       85500000
*                                                                       85560000
*        CTCOMP SAVE AREA DSECT                                         85620000
*                                                                       85680000
CTSAVAR  DSECT                                                          85740000
CTREGSV  DS    11F                                                      85800000
CTSAVARZ EQU   *                                                        85860000
*                                                                       85920000
*                                                                       85980000
*        GENERAL SAVE AREA DSECT                                        86040000
*                                                                       86100000
MTSAVAR  DSECT ,                                                        86160000
MTSAVR1  DS    F                                                        86220000
MTSAVR1Z EQU   *                                                        86280000
MTSAVR2  DS    F                                                        86340000
MTSAVR2Z EQU   *                                                        86400000
MTSAVR3  DS    F                                                        86460000
MTSAVR3Z EQU   *                                                        86520000
MTSAVR4  DS    F                                                        86580000
MTSAVR4Z EQU   *                                                        86640000
MTSAVR5  DS    F                                                        86700000
MTSAVR5Z EQU   *                                                        86760000
         ORG   MTSAVR3                                                  86820000
MTSAVRB  DS    F                   R11 SAVE AREA FOR MTRDZ              86880000
MTSAVRBZ EQU   *                                                        86940000
         ORG   MTSAVR3                                                  87000000
MTREP    DS    CL80                OPERATOR REPLY AREA                  87060000
MTREPZ   EQU   *                                                        87120000
         END                                                            87180000
./  ADD    NAME=APLUUREC
UREC     TITLE 'UNIT RECORD COMMUNICATION -- OUTWRT, SELCARD  05/11/70' 00170000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00340000
*              5736-XM6 COPYRIGHT IBM CORP. 1969, 1970                  00510000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       00680000
         PRINT OFF                 COPY APLDEFN ZSYMBOLS                01360000
         COPY  APLDEFN                                                  01530000
         COPY  ZSYMBOLS                                                 01700000
         TITLE 'UNIT RECORD COMMUNICATION -- OUTWRT, SELCARD  05/11/70' 01870000
URSECT   CSECT                                                          02040000
         PRINT ON,NOGEN                                                 02210000
         ENTRY OUTWRT                                                   02380000
         ENTRY OUTWRTL                                                  02550000
         ENTRY SELCARD                                                  02720000
         ENTRY UTCARD                                                   02890000
         ENTRY UTCARDNL                                                 03060000
         ENTRY VTOZ                                                     03230000
         ENTRY ZTOV                                                     03400000
         EXTRN UTDATE                                                   03570000
         ENTRY PRTDCB,RDRDCB,PCHDCB,WSDMPDCB                            04080000
*                                                                       05100000
*        OUTPUT MESSAGE WRITER                                          05270000
*        CALL ...  BAL LKR,OUTWRT   OR  BAL LKR,OUTWRTL                 05440000
*                  DC  AL4(TEXT)                                        05610000
*              TEXT CONSISTS OF EBCDIC TO BE PRINTED, INCLUDING         05780000
*              CONTROL CHARACTERS ..                                    05950000
*              X'00' - X'0F'       PRINT FOLLOWING N BYTES IN HEX       06120000
*              X'10'               PRINT NEXT 4 BYTES AS DECIMAL INT    06290000
*                                  WITH NO LEADING BLANKS               06460000
*              X'11'               PRINT NEXT 16 BYTES AS WORKSPACE     06630000
*                                  NUMBER AND NAME                      06800000
*              X'12'               PRINT NEXT BYTE AS 3-CHAR DEC INT    06970000
*              X'13'               PRINT NEXT 12 BYTES AS TIME STAMP    07140000
*                                  (8 BYTES ZSYMBOL DATE, 4 BYTES OF    07310000
*                                  300THS OF SECONDS)                   07480000
*              X'14'               FILL LINE WITH BLANKS TO COLUMN 102, 07650000
*                                  AND INSERT 18 BYTES OF TIME OF DAY   07820000
*              X'FD'               REPLY FROM OPERATOR EXPECTED         07990000
*                                       AFTER MESSAGE. IF A WTOR        08160000
*                                      REPLY IS EXPECTED THE ADDRESS    08330000
*                                      FOR THE RESPONSE IS PASSED       08500000
*                                      IN REGISTER 1.                   08670000
*              X'FE'               END OF TEXT, USE AS PAGE HEADING     08840000
*              X'FF'               END OF TEXT                          09010000
*        OUTWRT  SENDS LINE TO SYSLST                                   09180000
*        OUTWRTL SENDS LINE TO SYSLST AND SYSLOG                        09350000
*        ALL REGISTERS PRESERVED                                        09520000
*                                                                       09690000
OUTWRTL  MVI   0(LKR),1            SET SYSLOG FLAG IN CALLING SEQUENCE  09860000
*              ALL REGISTERS PRESERVED                                  10030000
OUTWRT   PROLOG OUTLOC,OUTLOCND                                         10200000
         STM   0,10,OUTLOC                                              10370000
         MVC   OWAD(4),0(LKR)      TEXT ADDRESS AND SYSLOG FLAG         10540000
         NI    OWAD,255-REPMASK    RESET REPLY FLAG                     10710000
         MVC   OWBUF-8(8),OWPFX    UTCARD MAY PREFIX WITH 'SYSLOG'      11730000
         MVC   OWPFX(8),=CL8' '    OR 'SYSIPT'                          11900000
         L     5,OWAD              TEXT ADDR                            12070000
         LA    2,1                                                      12240000
         LA    3,OWBUF+123         END TEST FOR BXLE                    12410000
         LA    4,OWBUF                                                  12580000
OWA      CLI   0(5),X'FE'          LOOK FOR CONTROL CHARS IN TEXT       12750000
         BH    OWC                 END OF TEXT                          12920000
         BE    OWPH                END OF TEXT, MAKE PAGE HEADING       13090000
         CLI   0(5),X'FD'          IS THIS WTOR                         13260000
         BNE   OWA1                NOT END OF TEXT                      13430000
         OI    OWAD,REPMASK        REPLY WANTED                         13600000
         B     OWC                                                      13770000
OWA1     SR    0,0                                                      13940000
         IC    0,0(5)                                                   14110000
         CLI   0(5),X'10'          CHECK FOR HEX                        14280000
         BL    OWHEX                                                    14450000
         BE    OWDEC               OR DECIMAL FULLWORD                  14620000
         CLI   0(5),X'12'                                               14790000
         BL    OWWSN               PRINT WSNAME                         14960000
         BE    OWDEC1              PRINT NNN FROM FOLLOWING BYTE        15130000
         CLI   0(5),X'14'                                               15300000
         BL    OWTS                PRINT TIMESTAMP                      15470000
         BE    OWTOD               PRINT TIME OF DAY                    15640000
         STC   0,0(4)              NOT CONTROL CHAR -- STORE DATA       15810000
OWB      LA    5,1(5)              ADVANCE TEXT POINTER                 15980000
OWD      BXLE  4,2,OWA             AND OUTPUT BUFFER POINTER            16150000
         LR    4,3                                                      16320000
OWC      LA    1,OWBUF             OFF END OF BUFFER TREATED LIKE FF    16490000
         MVI   0(4),C' '                                                16660000
         BCTR  4,0                 DELETE TRAILING BLANKS (FOR SYSLOG)  16830000
         CLI   0(4),C' '                                                17000000
         BE    *-6                                                      17170000
         LA    4,1(4)              TRUE COUNT                           17340000
         SR    4,1                                                      17510000
         BP    *+8                                                      17680000
         LA    4,1                 EMPTY LINE -- PRINT 1 BLANK          17850000
         LA    4,13(4)        ALLOW FOR LENGTH FIELD AND PREFIX     K14 21930000
         STH   4,OWBUF-13     LENGTH IF NORMAL LINE                 K14 22100000
         BCTR  4,0                                                  K14 22270000
         STH   4,LENGTH       LENGTH FOR WTO                        K14 22440000
OWL      CLI   SWITCH,X'01'        IS NEW PAGE SWITCH SET               22610000
         BE    OWHEAD              PRINT HEADER LINE                    22780000
         L     7,LNECNT            TEST FOR END OF PAGE                 22950000
         LA    7,1(7)                                                   23120000
         ST    7,LNECNT                                                 23290000
         CLI   LNECNT+3,PAGLEN                                          23460000
         BH    OWHEAD                                                   23630000
         STM   13,14,R13SAVE                                            23800000
         LA    13,OSSAVE                                                23970000
         PUT   PRTDCB,OWBUF-13     WRITE LINE TO SYSPRINT               24140000
Q        LM    13,14,R13SAVE                                            24310000
         CLI   OWAD,1                                                   24480000
*                                  REPMASK NOT SPECIFICALLY TESTED.     24650000
         MVC   MSG(150),OWBUF                                           24820000
         BL    OWZ                 NO WRITE TO OPR                      24990000
         LA    1,LENGTH           PICK UP PARAMETER LIST FOR WTO        25160000
         BE    OWE                 WTO WITH NO REPLY EXPECTED           25330000
*              THIS IS A FAKE ICALL                                     25500000
         L     15,=A(UTLOG)                                             25670000
         L     12,=A(UTCARD+6)         NOTE ASSMPT ABOUT PROLOG MACRO   25840000
         BR    15                  EXIT WILL BE FROM UTCARD             26010000
*                                  NEW PAGE WITH HEADER                 26180000
OWHEAD   LA    7,1(0)                                                   26350000
         ST    7,LNECNT            RESET LINE COUNT                     26520000
         STM   13,14,R13SAVE                                            26690000
         LA    13,OSSAVE                                                26860000
         PUT   PRTDCB,OWSKBF-5     WRITE HEADING TO SYSPRINT            27030000
         PUT   PRTDCB,BLANK        PRINT BLANK LINE AFTER HEADING       27200000
         LM    13,14,R13SAVE                                            27370000
         MVI   SWITCH,X'00'        RESET NEW PAGE SWITCH                27540000
         B     OWL                                                      27710000
*              WRITE TO LOG, NO REPLY                                   27880000
OWE      WTO   MF=(E,(1))                                               28050000
OWZ      LM    0,10,OUTLOC                                              28390000
*        IRETURN                   WE MUST RETURN TO 4(LKR)             28560000
         LM    PR,LKR,0(LR)                                             28730000
         MVI   0(LKR),0            RESET SYSLOG FLAG IN CALL            28900000
         B     4(LKR)                                                   29070000
*                                                                       29240000
OWDEC    MVC   OWTM(4),1(5)                                             29410000
         L     0,OWTM              CONVERT FULLWORD INT TO DECIMAL      29580000
         CVD   0,OWTD                                                   29750000
         MVC   OWTM(12),OWPAT                                           29920000
         LA    1,OWTM+11           PREPARE TO ELIMINATE LEADING BLANKS  30090000
         EDMK  OWTM(12),OWTD+2                                          30260000
         MVC   0(11,4),0(1)        LEFT-JUSTIFIED CONST TO BUFFER       30430000
         LA    4,OWTM+11(4)                                             30600000
         SR    4,1                                                      30770000
         LA    5,4(5)              ADVANCE OVER CONSTANT IN TEXT        30940000
         B     OWB                 COMPLETE POINTER UPDATING            31110000
OWPAT    DC    X'40202020202020202020212040'                            31280000
*                                                                       31450000
OWDEC1   IC    0,1(5)              CONVERT 1 BYTE TO DECIMAL FOR THINGS 31620000
         CVD   0,OWTD                                                   31790000
         UNPK  0(3,4),OWTD         LIKE SYSNNN                          31960000
         OI    2(4),C'0'                                                32130000
         LA    4,2(4)                                                   32300000
         LA    5,1(5)                                                   32470000
         B     OWB                                                      32640000
*                                                                       32810000
OWHEX    UNPK  0(7,4),1(4,5)       UNPACK POSSIBLY LONG STRING          32980000
         TR    0(15,4),HTOV                                             33150000
         LA    4,6(4)              BY A SERIES OF SHORT UNPACKS         33320000
         LA    5,3(5)                                                   33490000
         S     0,=F'3'                                                  33660000
         BH    OWHEX                                                    33830000
         AR    5,0                                                      34000000
         AR    4,0                 RESIDUAL BYTES OF LAST UNPACK        34170000
         AR    4,0                                                      34340000
         BCT   4,OWB                                                    34510000
*                                                                       34680000
*              PRINT LIBRARY NUMBER AND WORKSPACE NAME                  34850000
OWWSN    MVC   OWTD(16),1(5)       MOVE WSNO, WSNAME TO OUR STORAGE     35020000
         LA    5,16(5)             ADVANCE TEXT POINTER                 35190000
         L     0,OWTD                                                   35360000
         CVD   0,OWTD2                                                  35530000
         MVC   0(13,4),OWPAT                                            35700000
         EDMK  0(12,4),OWTD2+2                                          35870000
         CLI   OWTD+WFLNAME-WFLLIB,11 NOW SOME VALIDITY CHECKING ON THE 36040000
         BNH   OWW1                WORKSPACE NAME. 1ST BYTE MUST BE     36210000
*                                  COUNT OR NAME MUST BE APLDIRECTORY   36380000
         CLC   OWTD+WFLNAME-WFLLIB(12),=C'APLDIRECTORY'                 36550000
         BE    OWW3                                                     36720000
*                                  IF NEITHER, WORKSPACE IS PROBABLY    36890000
         MVC   0(12,4),=C'(ILLEGIBLE) '  IN BAD SHAPE                   37060000
         LA    4,12(4)             ADVANCE OUTPUT POINTER               37230000
         LA    0,16                AND PRINT FILE LABEL IN HEX          37400000
         SR    5,0                                                      37570000
         B     OWHEX                                                    37740000
OWW3     MVC   13(11,4),=C'*DIRECTORY*'                                 37910000
         LA    4,23(4)             ADVANCE OUTPUT POINTER               38080000
         B     OWB                                                      38250000
OWW1     SR    1,1                 PREPARE TO MOVE AND TRANSLATE WSNAME 38420000
         IC    1,OWTD+WFLNAME-WFLLIB                                    38590000
         LA    4,12(4)                                                  38760000
         CLI   OWTD+WFLNAME-WFLLIB,0  IF COUNT IS 0, PRINT NO NAME      38930000
         BCTR  1,0                                                      39100000
         BE    OWB                                                      39270000
         EX    1,OWMV                                                   39440000
         EX    1,OWTR                                                   39610000
         LA    4,1(4,1)            LIBRARY NO PLUS WSNAME LENGTH, -1    39780000
         B     OWB                                                      39950000
OWMV     MVC   1(0,4),OWTD+WFLNAME-WFLLIB+1                             40120000
OWTR     TR    1(0,4),ZTOV                                              40290000
         SPACE 2                                                        40460000
OWTS     MVC   0(8,4),1(5)         PRINT DATE AND TIME OF DAY           40630000
         TR    0(8,4),ZTOV         GET EBCDIC FROM ZSYMBOLS             40800000
         MVI   2(4),C'/'           ZSLASH NOT IN ZTOV TRANSLATE TABLE   40970000
         MVI   5(4),C'/'                                                41140000
         MVC   OWTD(4),9(5)        PREPARE TO FORMAT TIME               41310000
         LA    5,12(5)                                                  41480000
         L     1,OWTD              AS HHH.MM.SS                         41650000
OWTS2    SR    0,0                 (7 RHO 10) REP 100 BASE              41820000
         A     1,=F'150'                                                41990000
         D     0,=F'300'              0 60 60 REP FLOOR TIME DIV 300    42160000
         SR    0,0                                                      42330000
         D     0,=F'60'            SPLIT OFF SECONDS                    42500000
         LR    6,0                                                      42670000
         SR    0,0                                                      42840000
         D     0,=F'60'            THEN MINUTES                         43010000
         LR    7,0                                                      43180000
         M     0,=F'100'                                                43350000
         AR    1,7                                                      43520000
         M     0,=F'100'                                                43690000
         AR    1,6                                                      43860000
         CVD   1,OWTD                                                   44030000
         MVC   8(10,4),OWTSPAT                                          44200000
         EDMK  8(10,4),OWTD+4                                           44370000
         LA    4,17(4)             AND AS FORMATTED IN BUFFER           44540000
         B     OWB                                                      44710000
OWTSPAT  DC    X'402021204B20204B2020' TO GET  HHH.MM.SS                44880000
         SPACE 2                                                        45050000
OWPH     MVI   SWITCH,X'01'        INDICATE PAGE HEADING REQUIRED       46750000
         LA    1,OWBUF-12     CALCULATE                             K14 46920000
         SR    4,1               LENGTH OF                          K14 47090000
         STH   4,OWSKBF-5           HEADING                         K14 47260000
         MVC   OWSKBF,OWBUF-8      HEADING HAS SEPARATE BUFFER          47600000
         B     OWZ                                                      47770000
*                                                                       47940000
OWTOD    LA    1,OWBUF+93          FILL WITH BLANKS AND PRINT DATE,TIME 48110000
         LA    0,1                                                      48280000
         MVI   0(4),C' '                                                48450000
         BXLE  4,0,*-4                                                  48620000
         LA    4,OWBUF+94          MIGHT HAVE TO TRUNCATE               48790000
         L     1,=A(UTDATE)        NOW IN EBCDIC                        48960000
         MVC   0(8,4),0(1)                                              49130000
         GETIME TU                 NOW IN 300THS                        49300000
         B     OWTS2                                                    49470000
         TITLE 'SELCARD -- READ A WORKSPACE SELECTION CARD'             49640000
*                                                                       49810000
*        ON ENTRY, R1 = ADDRESS TO STORE 4 WORDS OF LIB NO, NAME        49980000
*                  R0 NONZERO MEANS LOG ERROR MESSAGE FOR PREV CARD     50150000
*              IF NO LIB NUMBER ON CARD, STORED NO. IS X'80000000'      50320000
*              IF NO WSNAME ON CARD, CHAR COUNT OF NAME IS 0            50490000
*              LOWERCASE EBCDIC IS MAPPED INTO UNDERBARRED APL ALPHAS   50660000
*              BLANK CARDS ARE IGNORED                                  50830000
*              OTHER CARDS ARE FLAGGED                                  51000000
*              ALL REGISTERS PRESERVED                                  51170000
*                                                                       51340000
SELCARD  PROLOG SELLOC,SELLOCND                                         51510000
         STM   0,6,SELLOC                                               51680000
         LR    6,1                 RETAIN SINK ADDRESS                  51850000
         XC    0(16,6),0(6)        CLEAR SINK AREA                      52020000
         LTR   0,0                                                      52190000
         BNZ   SELBAD              COMPLAIN ABOUT PREV CARD, THEN READ  52360000
         CLI   SELEOF,0            IF END OF FILE PENDING,              52530000
         BE    SELA                                                     52700000
SELE     MVI   0(6),X'80'          FAKE AN 'END' CARD AND COMPLAIN      52870000
         MVC   WFLNAME-WFLLIB(4,6),=AL1(3,ZE,ZN,ZD)                     53040000
         ICALL OUTWRTL             'END' CARD AND COMPLAIN              53210000
         DC    AL4(SELEMSG)                                             53380000
         MVI   SELEOF,1                                                 53550000
         B     SELZ                                                     53720000
SELA     SR    0,0                 ASSUME NO ERROR, PREV CARD           53890000
SELR     LA    1,BUF               READ NEXT CARD                       54060000
         ICALL UTCARD                                                   54230000
         B     SELE                END FILE RETURN                      54400000
         LA    3,BUF+79            ELSE PREPARE TO SCAN CARD            54570000
         LA    2,1                                                      54740000
         LA    4,BUF                                                    54910000
SELC     CLI   0(4),C' '           SKIP LEADING BLANKS                  55080000
         BNE   SELB                                                     55250000
         BXLE  4,2,SELC                                                 55420000
         B     SELA                THOROUGHLY BLANK                     55590000
SELB     CLI   0(4),C'0'                                                55760000
         BNL   SELD                NUMERIC FIELD                        55930000
         MVI   0(6),X'80'          NO LIBRARY NUMBER                    56100000
         B     SELF                                                     56270000
SELD     LR    5,4                 PREPARE TO CONVERT NUMBER            56440000
         LCR   1,4                                                      56610000
SELH     CLI   1(4),C'0'                                                56780000
         BL    *+8                                                      56950000
         BXLE  4,2,SELH                                                 57120000
SELM     AR    1,4                                                      57290000
         C     1,=F'11'                                                 57460000
         BNL   SELBAD                                                   57630000
         EX    1,SELPK             REASONABLE SIZED INTEGER             57800000
         CVB   1,DTEMP                                                  57970000
         ST    1,0(6)              STASH IT AWAY                        58140000
         LA    4,1(4)                                                   58310000
SELF     CLI   0(4),C' '           RESUME BLANK-SKIPPING                58480000
         BNE   SELI                                                     58650000
         BXLE  4,2,SELF                                                 58820000
         B     SELZ                NO WSNAME                            58990000
SELPK    PACK  DTEMP(8),0(0,5)                                          59160000
SELI     LCR   1,4                 PREPARE TO SCAN WSNAME               59330000
         LR    5,4                                                      59500000
SELN     CLI   0(4),C' '                                                59670000
         BE    SELP                                                     59840000
         CLI   0(4),C'-'           VALIDATE NONBLANKS                   60010000
         BE    SELL                                                     60180000
         CLI   0(4),C'='                                                60350000
         BE    SELL                                                     60520000
         CLI   0(4),C'a'           LOWERCASE A                          60690000
         BL    SELBAD                                                   60860000
SELL     BXLE  4,2,SELN                                                 61030000
SELP     AR    1,4                                                      61200000
         STC   1,4(6)                                                   61370000
         CLI   4(6),11             MAX 11 CHARS                         61540000
         BH    SELBAD                                                   61710000
         BCTR  1,0                                                      61880000
         EX    1,SELMV             MOVE NAME TO SINK                    62050000
         EX    1,SELTR             TRANSLATE TO Z-SYMBOLS               62220000
SELZ     LM    0,6,SELLOC                                               62390000
         IRETURN                                                        62560000
SELMV    MVC   5(0,6),0(5)                                              62730000
SELTR    TR    5(0,6),VTOZ                                              62900000
SELBAD   ICALL OUTWRTL                                                  63070000
         DC    AL4(SELMSG)                                              63240000
         BAL   0,SELR              GUARANTEE R0 NONZERO FOR ERROR       63410000
SELEOF   DC    FL1'0'              END-FILE FLAG                        63580000
         TITLE 'UTCARD -- READ SYSIPT OR SYSLOG'                        63750000
*                                                                       63920000
*              ON ENTRY, R0 = 0 IF READING FROM SYSIPT                  64090000
*                  IF NONZERO, TAKE NEXT INPUT (OR 'CANCEL' REQUEST)    64260000
*                  FROM SYSLOG                                          64430000
*                  R1 = BUFFER ADDRESS                                  64600000
*              RETURN TO 4(LKR) NORMALLY                                64770000
*              RETURN TO 0(LKR) ON END FILE, /*, /&                     64940000
*              SAVES ALL REGISTERS                                      65110000
*                                                                       65280000
UTCARDNL PROLOG UTT,UTTL                                                65450000
         MVI   NOLIST,1                                                 65620000
         LA    12,UTCARD+6                                              65790000
         USING UTCARD+6,12                                              65960000
         B     UTC1                                                     66130000
UTCARD   PROLOG UTT,UTTL                                                66300000
         MVI   NOLIST,0            LOG IT TO SYSLST                     66470000
UTC1     STM   0,10,UTT                                                 66640000
         LA    4,92           PUT LENGTH IN WTOR LIST IN CASE       K14 67150000
         STH   4,LENGTH            IT IS CLOBBERED BY A PREVIOUS COMND  67320000
         LTR   0,0                 DETERMINE SYSIPT OR SYSLOG           67660000
         BNZ   UTLOG                                                    67830000
         MVC   OWPFX(8),SYSIPT                                      K15 68000000
         CLI   EOFSW,1             PREVIOUS END-OF-FILE ?          P051 68170000
         BE    UTC2                BRANCH IF YES, TAKE EOF EXIT    P051 68340000
         MVI   EOFSW,1             SET EOF CONDITION AS DEFAULT    P051 68510000
         STM   13,15,R13SAVE                                            70550000
         LA    13,OSSAVE                                                70720000
         GET   RDRDCB,UTBUF                                             70890000
         MVI   EOFSW,0             SET SWITCH --- NO END OF FILE   P051 71060000
         LM    13,14,R13SAVE       NO POINT IN RESTORING R15            71230000
UTCA     L     LKR,12(LR)          RESTORE EXIT                         71400000
         LA    LKR,4(LKR)          STEP PAST EOF RETURN                 71570000
         ST    LKR,12(LR)          **** NOTE LINKAGE CONVENTION ASSUMPT 71910000
UTC3     CLI   NOLIST,0            IS CARD TO BE LOGGED TO SYSLST       72080000
         BNE   UTC2                SKIP IF NOT                          72250000
         ICALL OUTWRT                                                   72420000
         DC    AL4(UTBUF)                                               72590000
         B     UTC2                SKIP ROUND REGISTER RESTORE          73100000
UTCOM    LM    13,15,R13SAVE       RESTORE REGISTERS BEFORE READ        73270000
UTC2     LM    0,10,UTT            RESTORE ALL REGISTERS                73610000
         MVC   0(80,1),UTBUF       INPUT TO CALLER'S BUFFER             73780000
         IRETURN                                                        73950000
UTLOG    MVC   OWPFX(8),SYSLOG                                      K15 74120000
         MVI   UTBUF,C' '                                               74290000
         MVC   UTBUF+1(79),UTBUF                                        74460000
         ST    14,R13SAVE          WTOR USES REGISTER 14                75990000
          WTOR ,UTBUF,,,MF=(E,WTORLIST)  MSG HAS BEEN LOADED BY CALLER  76160000
         WAIT  ECB=ECBAD                                                76330000
         L     14,R13SAVE                                               76500000
         XC    ECBAD(4),ECBAD      RESET ECBAD TO 0                     76670000
         CLI   UTBUF,C'/'          ASSUME ANYTHING BEGINNING WITH /     77010000
         BE    UTC2                IS END OF FILE SIGNAL                77180000
         MVC   UTCAN,UTBUF         CHECK FOR CANCEL                     77350000
         OC    UTCAN,=CL7' '                                            77520000
         CLC   UTCAN,=C'CANCEL '                                        77690000
         BNE   UTCA                PLOW ONWARDS UNLESS 'CANCEL' REQUEST 77860000
UTCC     CANCEL                                                         78030000
SYSIPT   DC    CL8'SYSIN'                                           K15 81430000
SYSLOG   DC    CL8'CONSOLE'                                         K15 81600000
RDRDCB   DCB   DDNAME=SYSIN,MACRF=(GM),DSORG=PS,LRECL=80,EODAD=UTCOM,  X81770000
               RECFM=FB,DEVD=DA                                         81940000
PRTDCB   DCB   DDNAME=SYSPRINT,MACRF=(PM),DSORG=PS,RECFM=VBA,LRECL=137,X82110000
               BLKSIZE=3325,DEVD=DA                                     82280000
PCHDCB   DCB   RECFM=FB,DDNAME=SYSPUNCH,DSORG=PS,LRECL=80,MACRF=(PM),  X82450000
               BLKSIZE=3200,DEVD=DA                                     82620000
WSDMPDCB DCB   DDNAME=WSDUMP,MACRF=(W),DSORG=PS,LRECL=125,BLKSIZE=882, X82790000
               RECFM=VBA                                                82960000
LNECNT   DC    A(55)                                                    83130000
PAGLEN   EQU   55                                                       83300000
R13SAVE  DC    3F'0'                                                    83470000
OSSAVE   DS    18F                                                      83640000
WTORLIST DS    0F                  ORDER OF THIS PARM LIST IS MANDATORY 83810000
         DC    AL1(80)             REPLY LENGTH                         83980000
         DC    AL3(UTBUF)   REPLY ADDRESS                               84150000
         DC    A(ECBAD)    &ECB                                         84320000
LENGTH   DC    AL2(80)             MESSAGE LENGTH                       84490000
         DC    AL2(0)                                                   84660000
         DC    CL8'APL'       CONSOLE MESSAGE HEADER                K19 84830000
MSG      DC    150C' '             MESSAGE                              85000000
ECBAD    DC    F'0'                                                     85170000
BLANK    DS    0F                                                       85340000
         DC    X'000600004040'                                          85510000
SWITCH   DC    X'00'                                                    85680000
NOLIST   DC    X'00'                                                    86020000
UTCAN    DS    CL7                                                      86190000
REPMASK  EQU   X'08'                                                    86360000
SELEMSG  DC    C'EOF -- END CARD PROVIDED'                              86530000
         DC    X'FF'                                                    86700000
SELMSG   DC    C'INCORRECT SELECTION CARD '                             86870000
BUF      DC    80X'FF'             MUST FOLLOW SELMSG                   87040000
         DC    X'40FF'                                                  87210000
UTBUF    DS    CL80                                                     87380000
         DC    X'FF'                                                    87550000
         DS    0F                  LENGTH                               87720000
         DC    H'6'                 COUNT OF                            87890000
         DC    H'0'                  HEADING.                           88060000
         DC    C'1'                NEW PAGE ASA CONTROL CHAR            88230000
OWSKBF   DC    CL132' '            PAGE HEADING BUFFER                  88400000
OWPFX    DC    CL8' '              MESSAGE ORIGINATOR                   88570000
EOFSW    DC    X'00'               END-OF-FILE SWITCH FOR CONTROL  P051 88740000
         DC    F'0'                LENGTH COUNT OF MESSAGE              88910000
         DC    C' '                NEXT LINE ASA CONTROL CHAR           89080000
         DC    CL8' '              MUST PRECEDE OWBUF                   89250000
OWBUF    DS    150C                                                     89420000
ZTOV     EQU   *-ZA                                                     89590000
         DC    C'ABCDEFGHIJKLMNOPQRSTUVWXYZ-'                           89760000
         DC    C'abcdefghijklmnopqrstuvwxyz='                           89930000
*              ABOVE LINE IS LOWERCASE EBCDIC                           90100000
HTOV     EQU   *-C'0'                                                   90270000
         DC    C'0123456789'                                            90440000
         DC    C'ABCDEF'                                                90610000
VTOZ     EQU   *-C' '              FOR SAFETY                           90780000
         ORG   VTOZ+C'-'                                                90950000
         DC    AL1(ZDELTA)                                              91120000
         ORG   VTOZ+C'='                                                91290000
         DC    AL1(ZDELTAU)                                             91460000
         ORG   VTOZ+C'a'           LOWERCASE A                          91630000
         DC    AL1(ZAU,ZBU,ZCU,ZDU,ZEU,ZFU,ZGU,ZHU,ZIU)                 91800000
         ORG   VTOZ+C'j'           LOWERCASE J                          91970000
         DC    AL1(ZJU,ZKU,ZLU,ZMU,ZNU,ZOU,ZPU,ZQU,ZRU)                 92140000
         ORG   VTOZ+C's'           LOWERCASE S                          92310000
         DC    AL1(ZSU,ZTU,ZUU,ZVU,ZWU,ZXU,ZY,ZZU)                      92480000
         ORG   VTOZ+C'A'           UPPERCASE A                          92650000
         DC    AL1(ZA,ZB,ZC,ZD,ZE,ZF,ZG,ZH,ZI)                          92820000
         ORG   VTOZ+C'J'           UPPERCASE J                          92990000
         DC    AL1(ZJ,ZK,ZL,ZM,ZN,ZO,ZP,ZQ,ZR)                          93160000
         ORG   VTOZ+C'S'           UPPERCASE S                          93330000
         DC    AL1(ZS,ZT,ZU,ZV,ZW,ZX,ZY,ZZ)                             93500000
         ORG   VTOZ+C'0'                                                93670000
         DC    AL1(Z0,Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9)                       93840000
         ORG                                                            94010000
         LTORG                                                          94180000
OUTLOC   DSECT                                                          94350000
         DS    11F                                                      94520000
OWAD     DS    A                                                        94690000
OWTM     DS    4F                                                       94860000
OWTD     DS    2D                                                       95030000
OWTD2    DS    D                                                        95200000
OUTLOCND EQU   *                                                        95370000
SELLOC   DSECT                                                          95540000
         DS    7F                                                       95710000
DTEMP    DS    D                                                        95880000
SELLOCND EQU   *                                                        96050000
UTT      DSECT                                                          96220000
         DS    11F                                                      96390000
UTTL     EQU   *                                                        96560000
         END                                                            96730000
./  ADD    NAME=TAPEOS
        TITLE 'INTERFACE BETWEEN DOS CONTROL BLOCKS AND OS EXCP'        00860000
         PRINT NOGEN                                                    01720000
*              5734-XM6 COPYRIGHT IBM CORP. 1969, 1970                  02580000
*      REFER TO INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO 120-2083       03440000
*                                                                       04300000
*         TAPEOS...INTERPRETER BETWEEN DOS..COMMAND CONTROL BLOCK       05160000
*     AND OS..I O BLOCK                                                 06020000
*                                                                       06880000
*                                                                       07740000
*         AT ENTRY TO OSMTEXCP/OSMTWAIT,R1 CONTAINS THE ADDRESS         08600000
*     OF THE DOS CCB.                                                   09460000
*     BEFORE ISSUEING EXCP UNDER OS , INFORMATION MUST BE               10320000
*     TRANSFERED FROM THE CCB TO THE IOB.                               11180000
*     THE IOB MUST CONTAIN THE ADDRESS OF AN EVENT CONTROL BLOCK        12040000
*     WHICH WILL CONTAIN THE COMPLETION CODE AFTER THE IO               12900000
*     COMPLETES.   OSMTWAIT RETURNS CONTROL WITH INFORMATION            13760000
*     FROM THE IOB TRANSFERED TO THE CCB.                               14620000
*                                                                       15480000
*                                                                       16340000
TAPEOS   CSECT                    TAPE EXCP AND WAIT ROUTINES           17200000
         EXTRN DCBCUR             POINTER TO CURRENT DCB                18060000
         ENTRY MTDCB4                                                   18920000
         ENTRY MTDCB5                                                   19780000
         TITLE 'OS EXCP INTERPRETER'                                    20640000
OSMTEXCP PROLOG SAVE,SAVEZ        ENTRY LINKAGE                         21500000
         ENTRY OSMTEXCP           OS EXCP ROUTINE                       22360000
         STM   0,9,SAVE1          SAVE CALLERS REGISTERS                23220000
         LR    9,1                TO REFERENCE CCB                      24080000
         USING CCB,9              CCB ADDRESS IN R9                     24940000
         TM    CCBTI,X'80'             IS EXCP NEEDED                   25800000
         BO    EXCP1                   YES                              26660000
         ICALL OSMTWAIT                NO,WAIT ON EVENT                 27520000
EXCP1    NC    CCBCT(3),=X'00007F'  ZERO OUT RES COUNT AND TRAFFIC BIT  28380000
         MVC   CCBSTAT(2),=X'0000' ZERO STATUS IN CCB                   29240000
         L     2,=A(DCBCUR)       POINTER TO CURRENT DCB                30100000
         L     2,0(2)             OPENED DCB ADDRESS                    30960000
         USING IHADCB,2           REFERENCE DCB                         31820000
         L     1,DCBIOBAD         IOBADDRESS FROM DCB                   32680000
         USING IOBECB,1                                                 33540000
         ST    2,IOBDCB           STORE DCB ADDRESS IN IOB              34400000
         MVC   IOBSTART(3),CCBCCWA  ADDRESS OF CHANNEL PROGRAM          35260000
         NI    IOBFLAG1,X'3F'     TURN OFF CHAINING FLAGS IN IOB        36120000
         MVC   TEMP+1(3),IOBSTART   FIND FIRST CCW AND TEST FOR         36980000
         L     5,TEMP               DATA / COMMAND CHAINING             37840000
         LA    5,0(5)                                                   38700000
        TM    4(5),X'C0'                                                39560000
         BZ    NOCHAIN                                                  40420000
         OI    IOBFLAG1,X'42'      TURN ON CMND CHN & UNRELATED FLAGS   41280000
NOCHAIN  XC    EVNTCB(4),EVNTCB        ZERO OUT ECB                     42140000
         EXCP  (1)                                                      43000000
         LM    0,9,SAVE1          RELOAD REGS                           43860000
         IRETURN                  RETURN TO CALLER                      44720000
         TITLE 'OS WAIT INTERPRETER'                                    45580000
OSMTWAIT PROLOG SAVE,SAVEZ                                              46440000
         STM   0,9,SAVE1                                                47300000
         ENTRY OSMTWAIT                                                 48160000
         LR    9,1                                                      49020000
         USING CCB,9              CCB ADDRESS IN R9                     49880000
         L     8,=A(DCBCUR)       POINTER TO CURRENT DCB                50740000
         L     8,0(8)             ADDRESS OF OPENED DCB                 51600000
         USING IHADCB,8                                                 52460000
         L     6,DCBIOBAD                                               53320000
         USING IOBECB,6                IOB ADDRESS IN REG 6             54180000
         LA    7,EVNTCB           ECB ADDRESS FOR WAIT                  55040000
         TM    EVNTCB,B'01000000' IS COMPLETE BIT ON                    55900000
         BC    1,POSTCCB          YES,POST CCB COMPLETE                 56760000
         WAIT  ECB=(7)            ISSUE OS WAIT ON ECB                  57620000
POSTCCB  MVC   CCBCT(2),IOBCSW+5  CSW COUNT                             58480000
         MVC   CCBSTAT(2),IOBCSW+3      STATUS FROM CSW                 59340000
         MVC   CCBCSWA(3),IOBCSW     LAST COMMAND                       60200000
         OI    CCBTI,X'80'        POST CCB COMPLETE                     61060000
WAITZ   LM     0,9,SAVE1                                                61920000
         IRETURN                  RETURN TO CALLER                      62780000
UE       EQU   1                                                        63640000
         DS    0F                                                       64500000
IOB4     DC    X'02'              UNRELATED FLAG ON                     65360000
         DC    3X'00'                                                   66220000
         DC    XL1'00'                                                  67080000
         DC    AL3(ECB4)                                                67940000
         DC    8F'0'                                                    68800000
ECB4     DC    F'0'                                                     69660000
IOB5     DC    X'02'              UNRELATED FLAG ON                     70520000
         DC    3X'00'                                                   71380000
         DC    XL1'00'                                                  72240000
         DC    AL3(ECB5)                                                73100000
         DC    8F'0'                                                    73960000
ECB5     DC    F'0'                                                     74820000
         DS    0F                                                       75680000
TEMP     DS    F                                                        76540000
MTDCB4   DCB   DSORG=PS,MACRF=(E),DDNAME=TAPE1,IOBAD=IOB4               77400000
MTDCB5   DCB   DSORG=PS,MACRF=(E),DDNAME=TAPE2,IOBAD=IOB5               78260000
         LTORG                                                          79120000
         PRINT OFF    APLDEFN                                           79980000
         COPY  APLDEFN                                                  80840000
         PRINT ON                                                       81700000
SAVE     DSECT                                                          82560000
SAVE1    DS    10F                                                      83420000
SAVEZ    EQU   *                                                        84280000
SAVE2    DSECT                                                          85140000
SAVE22   DS    10F                                                      86000000
SAVE2Z   EQU   *                                                        86860000
CCB      DSECT                                                          87720000
CCBCT    DS    H                                                        88580000
CCBTI    DS    H                                                        89440000
CCBSTAT  DS    H                                                        90300000
CCBLU    DS    H                                                        91160000
         DS    1C                                                       92020000
CCBCCWA  DS    AL3                                                      92880000
         DS    1C                                                       93740000
CCBCSWA  DS    AL3                                                      94600000
         DS    F                                                        95460000
         DCBD  DSORG=(PS)                                               96320000
TAPEOS   CSECT ,                   NO COMMENT                           97180000
         IOBECBD                                                        98040000
         END                                                            98900000